Thema Datum  Von Nutzer Rating
Antwort
Rot Datenkonsolidierung mit VBA
 25.06.2018 17:23:56 Tim
*****
NotSolved

Ansicht des Beitrags:
Von:
Tim		 Datum:
25.06.2018 17:23:56		 Views:
1041		 Rating:
     
Antwort:
  Ja
Thema:
Datenkonsolidierung mit VBA

Hallo liebe Forumsmitglieder,

derzeit stehe ich vor einem kleinen Problem. Ich habe einen Codebaustein geringfügig umgeschrieben, welcher einen Datensatz konsolidiert. Konkret heißt das, dass doppelte Einträge in der Spalte X dazuführen, dass in einer neuen Arbeitsmappe die Informationen aus Spalte Y nummeriert in der gleichen Zeile als neue Spalte hinzugefügt werden.

Beispiel: 
Ausgangsdatensatz

    Hersteller X----->Produkt A
    Hersteller X----->Produkt B
    Hersteller Y ----->Product C


wird zu:

    Hersteller X ------->Produkt A-------->Produkt B
    Hersteller Y------->Product C


Je öfter eine Überschneidung im der Herstellerzeile vorkommt, desto mehr Spalten werden hinzugefügt und die Informationen werden kopiert ... 

Nun brauche ich noch einmal eine Konsolidierung der neu hinzugefügten Spalten in einer Spalte. Hier habe ich versucht einen verschachtelten Loop zu bauen, damit zunächst die Spalten ineinander kopiert und darauf dieser Vorgang für alle Zeilen durchgeführt wird. Leider habe ich hier wohl einen Fehler drin, da das ineinander kopieren auch nur passieren soll, wenn die Zellendaten enthalten.

Mein bisheriger, kompletter Code:

?
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
Sub Consolidation()
   Dim zz&, wsnQ$, anZ&, anS&, dum$, maxWied As Byte, SpZ%(), ii%, jj%, pp%
   Dim wsIni As Worksheet, wsQ As Worksheet, wsZ As Worksheet
   Dim src As Range
   Dim x As Integer
   Dim bb As Integer
   Dim tt As Integer
    
    
   '                                                       Ini vorbereiten
   Set wsIni = Sheets("Cockpit")
   wsIni.Activate
   Columns("E:G").Delete
   '                                          Ziel-Blatt löschen, wenn ex.
   On Error Resume Next
   Sheets(wsIni.Cells(6, 2) & "").Delete
   On Error GoTo 0
   '                                            Quelldaten-Zeilen/-Spalten
   wsnQ = Cells(4, 2)
   Set wsQ = Sheets(wsnQ)
   anZ = Sheets(wsnQ).[A1].CurrentRegion.Rows.Count
   anS = Sheets(wsnQ).[A1].CurrentRegion.Columns.Count
   '                                        max. Anzahl Key-Wiederholungen
   dum = "'" & wsnQ & "'!" & Cells(5, 2) & "1:" & Cells(5, 2) & CStr(anZ)
   Cells(1, 5).FormulaArray = "=MAX(1*COUNTIF(" & dum & "," & dum & "))"
   maxWied = Cells(1, 5)
   Cells(1, 5).ClearContents
   ReDim SpZ(1 To maxWied, 1 To anS)
   '                                                Eintrag Ini-Hilfswerte
   Range(Cells(3, 5), Cells(3, 7)) = Split("von bis vor")
   zz = 8
   While Not IsEmpty(Cells(zz + 1, 1))
      zz = zz + 1
      Cells(zz, 5) = SpNumm(Cells(zz, 1))
      Cells(zz, 6) = SpNumm(Cells(zz, 2))
      Cells(zz, 7) = SpNumm(Cells(zz, 3))
   Wend
   '                                                   Sort Ini-Hilfswerte
   Range(Cells(5, 5), Cells(zz, 7)).Sort _
      Key1:=Range("G6"), Order1:=xlDescending, _
      Key2:=Range("E6"), Order2:=xlDescending, _
      Header:=xlYes, OrderCustom:=1, Orientation:=xlTopToBottom
   '                                                   Sort der Quelldaten
   wsQ.Activate
 
   '                            neues Blatt, Spaltenüberschriften kopieren
   Set wsZ = Worksheets.Add(After:=Sheets(1))
   wsZ.Name = wsIni.Cells(6, 2)
   wsQ.Rows(1).Copy Destination:=wsZ.Cells(1, 1)
   '                                zusätzl. Spaltenüberschriften einfügen
   zz = 5
   While Not IsEmpty(wsIni.Cells(zz + 1, 1))
      zz = zz + 1
      For ii = maxWied - 1 To 1 Step -1
         For jj = wsIni.Cells(zz, 6) - wsIni.Cells(zz, 5) To 0 Step -1
            wsQ.Cells(1, wsIni.Cells(zz, 5) + jj).Copy
            wsZ.Cells(1, wsIni.Cells(zz, 7)).Insert Shift:=xlToRight
            wsZ.Cells(1, wsIni.Cells(zz, 7)) = _
               wsZ.Cells(1, wsIni.Cells(zz, 7)) & " #" & CStr(ii + 1)
         Next jj
      Next ii
   Wend
    
   Application.CutCopyMode = False
   wsIni.Columns("E:G").Delete
 
   '                                                     Datenziele merken
   ii = 0
   For zz = 1 To wsZ.UsedRange.Count
      pp = InStr(wsZ.Cells(1, zz), "#")
      If pp > 0 Then
         For jj = 1 To ii
            If Left(wsZ.Cells(1, zz), pp - 2) = wsQ.Cells(1, jj) Then
               SpZ(Mid(wsZ.Cells(1, zz), pp + 1), jj) = zz
               Exit For
            End If
         Next jj
      Else
         If Not IsEmpty(wsZ.Cells(1, zz)) Then
            ii = ii + 1:  SpZ(1, ii) = zz
         End If
      End If
   Next zz
   '                                                      Daten übertragen
   jj = 1: dum = ""
   For zz = 2 To anZ
      If dum = wsQ.Cells(zz, SpNumm(wsIni.Cells(5, 2))) Then
         ii = ii + 1
      Else
         ii = 1:          jj = jj + 1
         dum = wsQ.Cells(zz, SpNumm(wsIni.Cells(5, 2)))
      End If
      For pp = 1 To anS
         If SpZ(ii, pp) > 0 Then wsZ.Cells(jj, SpZ(ii, pp)) = wsQ.Cells(zz, pp)
      Next pp
   Next zz
   Cells(2, 1).Select
    
   ActiveSheet.Range("H2", "H1000").NumberFormat = "m/d/yyyy"
   ActiveSheet.Range("L2", "L1000").NumberFormat = "m/d/yyyy"
    
        Columns("W:W").Insert Shift:=xlToRight, _
      CopyOrigin:=xlFormatFromLeftOrAbove
      Range("W1") = "Licenses/ Contracts Consolidation"
       
'Starten mit x in Spalte 3
 
bb = maxWied
tt = maxWied - 1
x = 2
 
 
Do While Cells(x, 24).Value <> ""
 
 
Cells(x, 23).Value = "-" & Cells(x, 23 + bb).Value
 
    Do While tt > 0 And IsNumeric(Cells(x, 23 + bb))
     
 
    Cells(x, 23).Value = Cells(x, 23).Value & vbCrLf & "-" & Cells(x, 23 + tt).Value
    Exit Do
    tt = tt - 1
     
Loop
 
x = x + 1
 
Loop
 
     
    Range("A:A").Columns.Hidden = True
Set src = Range("A1:AE600").CurrentRegion
ActiveSheet.ListObjects.Add(SourceType:=xlSrcRange, Source:=src, _
xlListObjectHasHeaders:=xlYes, tablestyleName:="TableStyleMedium2").Name = "Consolidation"
    
   ActiveWindow.FreezePanes = True
End Sub

Allerdings ist die konkrete Stelle, an der es klemmt diese hier:

?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
bb = maxWied
tt = maxWied - 1
x = 2
 
 
Do While Cells(x, 24).Value <> ""
 
 
Cells(x, 23).Value = "-" & Cells(x, 23 + bb).Value
 
    Do While tt > 0 And IsNumeric(Cells(x, 23 + bb))
     
 
    Cells(x, 23).Value = Cells(x, 23).Value & vbCrLf & "-" & Cells(x, 23 + tt).Value
    Exit Do
    tt = tt - 1
     
Loop
 
x = x + 1
 
Loop

Ich hoffe mir kann jemand weiterhelfen und verraten, wie ich die Loops ineinander verschachteln muss, damit es funktioniert ... 

Vielen Dank im Voraus und liebe Grüße,

Tim

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:
WYSIWYG-Editor, ctl00_Content_editor1



  • 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
Rot Datenkonsolidierung mit VBA
 25.06.2018 17:23:56 Tim
*****
NotSolved