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:
1523
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:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
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