Thema Datum  Von Nutzer Rating
Antwort
17.11.2014 11:11:49 Paulo Borges
NotSolved
17.11.2014 20:11:50 Gast81683
NotSolved
18.11.2014 14:06:39 Gast49573
Solved
Blau Bereiche über 2 Listboxen kopieren
18.11.2014 15:58:29 Gast44445
Solved
19.11.2014 22:57:20 Gast24084
Solved

Ansicht des Beitrags:
Von:
Gast44445
Datum:
18.11.2014 15:58:29
Views:
1379
Rating: Antwort:
 Nein
Thema:
Bereiche über 2 Listboxen kopieren

Wenn du mir ein Tip geben könntest wie es ausehen könnte,

Einfach&geschmacklos-quick&dirty

1 x einrichten:

Private Sub NameIt()
'
'******************************************************************************
' Name : NameIt / erstellt : 18.11.2014 / 15:07 / Sub
'------------------------------------------------------------------------------
'
' initialisiere Blöcke nach Definition
'
'******************************************************************************
'
Const A_BLOCK1 As String = "$A$2:$AI$38"
Const B_BLOCK1 As String = "$AK$2:$BS$38"

Dim c As Range, n As Name, x As Long, z As Long, sN As String
Dim oWb As Workbook

Set oWb = ThisWorkbook
oWb.Sheets("Export").Activate

For Each n In Names
   n.Delete
Next n

Set c = Range(A_BLOCK1)
z = c.Rows.Count

For x = 1 To 15
   sN = "Block" & Format(x, "00") & "a"   '<< wahlfrei benamsen
   oWb.Names.Add Name:=sN, RefersTo:=c
   Set c = c.Offset(z)
Next x

Set c = Range(B_BLOCK1)
z = c.Rows.Count

For x = 1 To 15
   sN = "Block" & Format(x, "00") & "b"   '<< wahlfrei benamsen
   oWb.Names.Add Name:=sN, RefersTo:=c
   Set c = c.Offset(z)
Next x

Set oWb = Nothing
End Sub

Userform hab ich zus. mit SpinButton1 aufgehübscht - vertauscht Quelle / Ziel - Listen

Option Explicit
Dim oWbk As Workbook
Dim oWsh As Worksheet
Dim aBlock(), bBlock()  'Arrays für Listenfelder

Private Sub CMD_Copy_Click()
Dim sc As Range, st As Range  'source / target

If ListBoxB.ListIndex < 0 Or ListBoxB.ListIndex < 0 Then
   Call MsgBox("keine gültige Auswahl!", vbCritical, "Abbruch")
   Exit Sub
End If

With oWsh
   Set sc = .Range(ListBoxB.Column(0))
   Set st = .Range(ListBoxA.Column(0))

   Select Case MsgBox("von " & sc.Address & " - nach " & st.Address, _
      vbOKCancel Or vbInformation Or vbDefaultButton1, "CMD_Copy")
         Case vbOK
            sc.Copy
            st.PasteSpecial Paste:=xlPasteValues
            Application.CutCopyMode = False
            sc.Cells(1).Select
            
            RefreshLists
            
         Case vbCancel
         '
   End Select
End With

End Sub

Private Sub SpinButton1_Change()
'
'******************************************************************************
' Name : SpinButton1_Change / erstellt : 18.11.2014 / 15:21 / Sub
'------------------------------------------------------------------------------
'
' vertausche Anzeigen in Listen (Quelle - Ziel)
'
'******************************************************************************
'

Select Case SpinButton1.Value
   Case 0
      With ListBoxA 'Target
       .Clear
      .List = aBlock
      End With
      With ListBoxB 'Source
         .Clear
         .List = bBlock
      End With
   Case 1
      With ListBoxA 'Target
       .Clear
      .List = bBlock
      End With
      With ListBoxB 'Source
         .Clear
         .List = aBlock
      End With
End Select
End Sub

Private Sub UserForm_Deactivate()
Set oWbk = Nothing
Set oWsh = Nothing
End Sub

Private Sub UserForm_Initialize()
Set oWbk = ThisWorkbook
Set oWsh = oWbk.Sheets("Export")

RefreshLists   'Neuaufbau der Listenfelder

End Sub

Private Sub RefreshLists()
'
'******************************************************************************
' Name : RefreshLists / erstellt : 18.11.2014 / 15:15 / Sub
'------------------------------------------------------------------------------
'
' Listenfelder haben 4 Spalten, Spalte 0 wird verborgen
'
'******************************************************************************
'
Dim n As Name, acnt As Long, bcnt As Long
Dim c As Range

oWsh.Activate

For Each n In oWbk.Names
   If Left(n.Name, 5) = "Block" Then   '<< wie in Sub NameIt()benannt !
      Select Case Right(n.Name, 1)     'ditto
      Case "a"
         acnt = acnt + 1
      Case "b"
         bcnt = bcnt + 1
      End Select
   End If
Next n

ReDim aBlock(1 To acnt, 0 To 3)
ReDim bBlock(1 To acnt, 0 To 3)
acnt = 0: bcnt = 0

For Each n In oWbk.Names
   If Left(n.Name, 5) = "Block" Then   '<< wie in Sub NameIt()benannt !
      Select Case Right(n.Name, 1)     'ditto
      Case "a"
         acnt = acnt + 1
         Set c = n.RefersToRange       '<< Ziel
         aBlock(acnt, 0) = c.Address   'Adresse zu
         aBlock(acnt, 1) = n.Name      'Ausgabe in Spalte
         Set c = Range(aBlock(acnt, 0))
         aBlock(acnt, 2) = c.Cells(4).Value  'sichtbarer Wert in Spalte
         aBlock(acnt, 3) = c.Cells(5).Value  'ditto
      Case "b"
         bcnt = bcnt + 1
         Set c = n.RefersToRange
         bBlock(bcnt, 0) = c.Address   '<< Quelle
         bBlock(bcnt, 1) = n.Name      'ditto
         Set c = Range(bBlock(bcnt, 0))
         bBlock(bcnt, 2) = c.Cells(4).Value
         bBlock(bcnt, 3) = c.Cells(5).Value
      End Select
   End If
Next n

With ListBoxA 'Bereich A - Ziel versorgen
    .ColumnCount = 4
    .ColumnWidths = "0; 60 ; 60; 60"
    .Clear
    .List = aBlock
End With

With ListBoxB 'Bereich B   - Quelle versorgen
    .ColumnCount = 4
    .ColumnWidths = "0; 60 ; 60; 60"
    .Clear
    .List = bBlock
End With

End Sub

 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
17.11.2014 11:11:49 Paulo Borges
NotSolved
17.11.2014 20:11:50 Gast81683
NotSolved
18.11.2014 14:06:39 Gast49573
Solved
Blau Bereiche über 2 Listboxen kopieren
18.11.2014 15:58:29 Gast44445
Solved
19.11.2014 22:57:20 Gast24084
Solved