Zeilen duplizieren - es läuft!
26.05.2003 13:28:45
Hermann
Hallo Peter,es läuft!!!
Nach ein paar Korrekturen habe ich dein Makro zum Laufen gebracht, Die Struktur hat gestimmt, nur so ein paar Indizes waren um +-1 verschoben. Und dann habe ich den Fall noch eingefügt, dass bei keinem Code auch kopiert wird.
Ich stell das Makro mal hier rein, aber wundere dich nicht über meine Comments im Makro, die brauch ich als nicht VBA-ler zur Stütze.
Sub Umkopieren1()
Dim T1$, T2$, m%, n%, z1%, z2%, k%, C$, C1$, C2(7) As String, D$, s%
T1 = "Tabelle1" ' Name der Tabelle1
T2 = "Tabelle2" ' Name der Tabelle2
z1 = 2 ' Zeilenzähler von Tabelle1 auf 2 (wegen Überschrift)
z2 = 2 ' Zeilenzähler von Tabelle2 auf 2 (wegen Überschrift)
Sheets(T1).Rows(1).Copy ' Kopieren der Überschrift von Tabelle1 in Tabelle2
Sheets(T2).Select: Rows(1).Select: ActiveSheet.Paste
Do While Sheets(T1).Cells(z1, 1) > Empty ' LOOP1: über alle belegten Zeilen der Tabelle1
C = Sheets(T1).Cells(z1, 3): n = 0: m = 0 ' Untersuche Wert in Spalte C (=3. Spalte)
If Len(C) = 0 Then ' kein Code in Spalte 3? (Hesi)
m = 1 ' Merker für kein Code in Spalte 3 (Hesi)
End If
Do While Len(C) > 0 ' LOOP2: über alle n Codes
n = n + 1 ' Anzahl Codes erhöhen
k = InStr(C, ",") ' suche die Position des Kommas
If k = 0 Then ' wenn kein Komma enthalten, d.h. nur 1 Code
C2(n) = Left(C, 7) ' Code = 7 Zeichen und dann EXIT
Exit Do ' LOOP2: Exit
End If '
C2(n) = Left(C, k - 1) ' Code extrahieren bis 1 Stelle vor Komma
C = Mid(C, k + 2) ' zu untersuchenden String C kürzen
Loop ' LOOP2: über alle n Codes
Sheets(T1).Rows(z1).Copy ' Kopiere Zeile aus Tabelle1
If m = 1 Then ' Zeile auch ohne Code einfügen (Hesi)
Rows(z2).Select: ActiveSheet.Paste ' Zeile auch ohne Code einfügen (Hesi)
z2 = z2 + 1 ' nächste Zeile in Tabelle2 (Hesi)
End If
For s = 1 To n ' LOOP3: Einfügen von n Zeilen in Tabelle2
Rows(z2).Select: ActiveSheet.Paste ' ganze Zeile einfügen
Cells(z2, 3) = C2(s) ' extrahierter Code in Zelle in Spalte 3
z2 = z2 + 1 ' nächste Zeile in Tabelle2
Next ' LOOP3: Ende
z1 = z1 + 1 ' nächste Zeile in Tabelle1
Loop ' LOOP1: über alle Zeilen der Tabelle1
End Sub
Danke nochmals und
Gruß Hermann