Zeilen kopieren und aufsplitten

[Rabe]

Hallo,

ich habe in einer Datei eine (lange) Liste von Zeilen.
Diese Zeilen sollen aufgesplittet werden, so daß jeder Begriff aus C einzeln in einer Zeile mit den restlichen Zellinhalten steht und in Spalte G jeweils eine 1. In C soll anschließend noch das führende Leerzeichen entfernt werden.

BOM

	A	B	C	D	E	F	G	H	I	J
6	Item #	Comment	Designator	Value	Voltage	Tolerance	Quantity	Footprint	Manufacturer	Manufacturer Part Number
7	1	Capacitor	C107, C108	470pF			2	Keramik RM75_d8	Murata	DEBB33D471KA2B
8	2	Capacitor	C200, C201, C204, C205	2,2µF			4	C_RM27.5H24.5B14.0L31.5	EPCOS	B32924C3225M
9	3	Capacitor	C202, C203	1,5µF			2	C_RM27.5H21.0B11.0L31.5	EPCOS	B32924C3155M
10	4	Capacitor	C206, C207, C208, C209	47nF	300V	20%	4	C_RM15.0H14.0B8.5L18.0	EPCOS	B32022A3473M
11	5	Capacitor	C349, C350, C351, C352	1nF			4	Keramik RM5_d8	Murata	DEBB33D102KA2B
12	6	Capacitor	C353	4,7nF			1	Keramik RM10_d16	Vishay	VY1472M63Y5UQ63V0
13	7	Capacitor	C400, C405, C409, C416	1,5µF			4	C_RM27.5H28.0B18.0L31.0	EPCOS	B32654A6155+000
14	8	Capacitor	C401, C402, C407, C408, C414, C415	1,5nF			6	C_RM22.5H15.0B6.0L26.5	Wima	FKP1U011505B00
15	9	Capacitor	C500, C501, C507	100nF			3	C_RM27.5H24.0B13.0L31.5	Wima	FKP1J031006D00
16	10	Capacitor	C502, C504	22nF			2	C_RM27.5H26.0B15.0L31.5	Wima	FKP1U022206F00
17	11	Capacitor	C503, C505	15nF			2	C_RM27.5H24.0B13.0L31.5	Wima	FKP1U021506D00
18	12	Capacitor pol.	C700, C701	100µF			2	C Panasonic HD Series  V Type  G Size	Panasonic	EEEHD1V101AP
19	13	Capacitor SMD	C100, C101, C102, C103	10pF	50V	10%	4	C_sm_0603
20	14	Capacitor SMD	C104, C105, C312, C313, C316, C318, C319, C327, C328, C331, C332, C340_A, C340_B, C344, C348, C600, C601, C604, C606, C608, C609, C610, C611, C612, C613, C614, C615, C616, C617, C618, C619, C621, C624, C625, C626, C627, C629, C702, C703, C704, C706	100nF	50V	10%	41	C_sm_0603

verwendete Formeln
Zelle	Formel	Bereich	N/A
A7:A20	=ZEILE(A7) - ZEILE($A$6)

Excel-Inn.de

Hajo-Excel.de

XHTML-Tabelle zur Darstellung in Foren, einschl. der neuen Funktionen ab Version 2007

Add-In-Version 19.07 einschl. 64 Bit

Mit diesem Makro wurde das gelöst, leider ist es aber (unendlich) langsam. Wie kann das schneller gemacht werden? Mit Array?

Sub WerteTrennen()
  
  loLetzte = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)   'letzte belegte Zeile in Spalte A (1) 
  For intZeile = loLetzte To 7 Step -1    'aktuelle Zeile 
     '   If IsError(intBauteile = Range("G" & intZeile)) Then 
     
     If Not WorksheetFunction.IsNumber(Range("G" & intZeile)) Then
        intBauteile = "1"
     Else
        intBauteile = Range("G" & intZeile) 'Anzahl Bauteile 
     End If
     intEinfüg = intBauteile - 1         'Anzahl einzufügende Zeilen 
     
     If intEinfüg > 0 Then
        'Zeilen einfuegen 
        Range("A" & intZeile + 1 & ":O" & intZeile + intEinfüg).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        
        'Zeilen runterkopieren 
        Range("A" & intZeile & ":o" & intZeile).Copy Range("A" & intZeile + 1 & ":o" & intZeile + intEinfüg)
        'Zahl der Bauteile auf 1 setzen 
        Range("G" & intZeile & ":G" & intZeile + intEinfüg).Value = 1
        
        'Werte aus C aufnehmen 
        arrWerte = Split(Range("C" & intZeile).Value, ",")
        'Werte am Komma trennen und untereinander einfuegen 
        Range("C" & intZeile).Resize(Ubound(arrWerte) + 1) = WorksheetFunction.Transpose(arrWerte)
        intZeile = intZeile + intEinfüg
     End If
  Next intZeile
  
  'entfernen führender Leerzeichen 
  loLetzte = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)   'letzte belegte Zeile in Spalte A (1) 
  Range("C7:C" & loLetzte).TextToColumns Destination:=Range("C7"), DataType:=xlFixedWidth
  'Zeilenhöhe anpassen 
  Rows("7:" & loLetzte).AutoFit
  
End Sub

VBA/HTML - CodeConverter für Office-Foren, AddIn für Excel/Word 2000-2013 - komplett in VBA geschrieben von Lukas Mosimann. Projektbetreuung durch mumpel
Code erstellt und getestet in Office 15

[Kuwer]

Hallo Ralf,

so sollte es etwas schneller gehen:

Option Explicit

Sub WerteTrennen_Uwe()
 Dim arrWerte As Variant, lngCalc As Long
 Dim lngBauteile As Long, lngLetzteZeile As Long, lngZeile As Long
 
 Application.ScreenUpdating = False
 lngCalc = Application.Calculation
 Application.Calculation = xlCalculationManual
 'letzte belegte Zeile in Spalte A (1)
 lngLetzteZeile = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
 For lngZeile = lngLetzteZeile To 7 Step -1
   lngBauteile = Application.Max(1, Cells(lngZeile, 7).Value)
   If lngBauteile > 1 Then
     Rows(lngZeile).Copy
     Rows(lngZeile).Resize(lngBauteile - 1).Insert
     'Werte aus C aufnehmen
     arrWerte = Split(Cells(lngZeile, 3).Value, ",")
     'Werte am Komma trennen und untereinander einfuegen
     Cells(lngZeile, 3).Resize(lngBauteile) = Application.Transpose(arrWerte)
   End If
 Next lngZeile
 'letzte belegte Zeile in Spalte A (1)
 lngLetzteZeile = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
 'entfernen führender Leerzeichen
 Range("C7:C" & lngLetzteZeile).TextToColumns Destination:=Range("C7"), DataType:=xlFixedWidth
 'Zahl der Bauteile auf 1 setzen
 Range("G7:G" & lngLetzteZeile).Value = 1
 'Zeilenhöhe anpassen
 Rows("7:" & lngLetzteZeile).AutoFit
 Application.Calculation = lngCalc
 Application.ScreenUpdating = False
End Sub

Mit Array wäre sicher auch möglich, aber die Zeilenabschnitte müssten ja trotzdem einzeln angefasst werden wegen der Formatierung(en)!?

Gruß Uwe

[Rabe]

Hi Uwe,

so sollte es etwas schneller gehen:

Mit Array wäre sicher auch möglich, aber die Zeilenabschnitte müssten ja trotzdem einzeln angefasst werden wegen der Formatierung(en)!?

ja, so geht es schneller, danke!

Zwei Probleme:
wenn keine Zahl in G steht, sondern ein Text (z.BH. "n.b.") dann bricht das Makro ab. Ich hatte da eine Überprüfung mit "If Not WorksheetFunction.IsNumber()" drin.

Wenn ich diese Prüfung einbaue, dann wird aber am Ende das "n.b." ebenfalls durch eine 1 überschrieben. Dieser Text sollte aber stehen bleiben.

zur Geschwindigkeit:
Wegen den beiden Auffälligkeiten habe ich erst mal noch mit meinem Makro rumprobiert und dort auch das Screenupdating ausgeschaltet, das hat erst mal nichts gebracht.
Dann habe ich noch mehr rumgespielt und viele Zeilen mit Formatierungen in den Hilfsblättern Tabelle1 und Tabelle2, die durch das Einfügen der Zeilen (wegen Spalte C) bei früheren Versuchen drin blieben, entfernt. Außerdem wurden aus dem Übersichtsblatt "Gesamt" (Vergleich verknüpfter Texte aus den Hilfstabellen) alle Formeln außer Zeile 7 entfernt und per Makro die Formeln nur so weit nach unten kopiert, wie in den Hilfsblättern Zeilen belegt sind.
Die Datei-Größe der Vorlage war dann auf 10% geschrumpft und plötzlich war das Makro ganz fix.

So bin ich eigentlich ganz zufrieden.


Array-Thema:
Eigentlich müssen die Zeilenabschnitte nicht mehr angefasst werden, da beim Einfügen der Zeilen doch das Format der drüber-Zeile übernommen wird? Andererseits ist das Format sowieso egal, da das Blatt eh nur ein Hilfsblatt ist.

Nun habe ich noch eine weitere Frage zu Textvergleich, aber da mache ich ein neues Thema auf.

[Kuwer]

Hi Ralf,

wenn keine Zahl in G steht, sondern ein Text (z.BH. "n.b.")

Mist, das habe ich in Deinem Beispiel wohl übersehen.  
Dann z.B. auch so:

Option Explicit

Sub WerteTrennen_Uwe()
 Dim arrWerte As Variant, lngCalc As Long
 Dim lngBauteile As Long, lngLetzteZeile As Long, lngZeile As Long
 
 Application.ScreenUpdating = False
 lngCalc = Application.Calculation
 Application.Calculation = xlCalculationManual
 'letzte belegte Zeile in Spalte A (1)
 lngLetzteZeile = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
 'Zahl der Bauteile auf 1 setzen, wenn keine Zahl vorhanden ist
 Range("G7:G" & lngLetzteZeile).SpecialCells(xlCellTypeConstants, 22).Value = 1
 Range("G7:G" & lngLetzteZeile).SpecialCells(xlCellTypeBlanks).Value = 1
 For lngZeile = lngLetzteZeile To 7 Step -1
   lngBauteile = Application.Max(1, Cells(lngZeile, 7).Value)
   If lngBauteile > 1 Then
     Rows(lngZeile).Copy
     Rows(lngZeile).Resize(lngBauteile - 1).Insert
     'Werte aus C aufnehmen
     arrWerte = Split(Cells(lngZeile, 3).Value, ",")
     'Werte am Komma trennen und untereinander einfuegen
     Cells(lngZeile, 3).Resize(lngBauteile) = Application.Transpose(arrWerte)
   End If
 Next lngZeile
 'letzte belegte Zeile in Spalte A (1)
 lngLetzteZeile = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
 'entfernen führender Leerzeichen
 Range("C7:C" & lngLetzteZeile).TextToColumns Destination:=Range("C7"), DataType:=xlFixedWidth
 'Zahl der Bauteile auf 1 setzen
 Range("G7:G" & lngLetzteZeile).Value = 1
 'Zeilenhöhe anpassen
 Rows("7:" & lngLetzteZeile).AutoFit
 Application.Calculation = lngCalc
 Application.ScreenUpdating = False
End Sub

Array-Thema:
Eigentlich müssen die Zeilenabschnitte nicht mehr angefasst werden, da beim Einfügen der Zeilen doch das Format der drüber-Zeile übernommen wird?

Gerade dieses Einfügen von Zeilen ist ja (vermutlich) die Hauptbremse.

Gruß Uwe

[Rabe]

Hi Uwe,

Gerade dieses Einfügen von Zeilen ist ja (vermutlich) die Hauptbremse.

als Array-Laie stelle ich es mir so vor:

• Ich lese den gesamten Daten-Block (Zeile 7 bis lngLetzteZeile) in ein Array ein: 10 Spalten (A-J) und (lngLetzteZeile - 6) Zeilen.
  
  
• Dann nehme ich für jede Zeile (von oben her) den Wert von Spalte 7 (= G) und schreibe den Array-Zeileninhalt  G.Value-mal in die Tabelle ab Zeile 7 ein, dann wird in Spalte C der Inhalt gesplittet und auf die Spalte verteilt und in G wird jeweils 1 geschrieben.
  
• Dann nehme ich mir die nächste Array-Zeile vor und schreibe den Inhalt G.Value-mal in die nächsten freien Zeilen.
  
• ...
  

bis das Array abgearbeitet ist.

so?

   loLetzte = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)   'letzte belegte Zeile in Spalte A (1) 
  For j = 1 To loLetzte
     For i = 1 To 10
        arr(i - 1, j - 1) = Cells(j, i)
     Next i
  Next j
  
  For j = 1 To loLetzte
     For i = 1 To 10
        If Not WorksheetFunction.IsNumber(arr(6, j - 1)) Then
           Cells(j, i) = arr(i - 1, j - 1)
        Else
           'hier nun der Kopie-Teil 
        End If
     Next i
  Next j

VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 15 - mit VBAHTML 12.6.0

das kann so eigentlich nicht funktionieren, da ja das loLetzte nicht mitwächst.

[schauan]

Hallo Ralf,

wenn Du Dein Array zellenweise füllst, verschenkst Du schon wieder viel. Wenn Du so vorgehen willst, dann übernehme den kompletten Bereich in ein Array und übertrage das dann entsprechend aufgearbeitet in ein zweites. Das zweite packst Du dann, wieder komplett, in die Tabelle.

Noch zwei Anmerkungen zur anderen Lösung.

Splitten kann man auch mit mehr als einem Zeichen. Nimm ", ", dann brauchst Du das Leerzeichen vor den "C" nicht mehr zu entfernen.

Autofit ist bei größeren Datenbeständen auch eine Bremse. Excel prüft dabei jede Zelle einzeln, ob die Spalte etwas schmaler oder breiter werden muss. Nimm, wenn möglich, eine feste, ausreichende Breite.

[Kuwer]

Hallo André,

Splitten kann man auch mit mehr als einem Zeichen. Nimm ", ", dann brauchst Du das Leerzeichen vor den "C" nicht mehr zu entfernen.

Das hatten wir doch schon hier:

http://www.clever-excel-forum.de/Thread-...0#pid25940
http://www.clever-excel-forum.de/Thread-...2#pid25942

Gruß Uwe

[schauan]

Hallo Uwe,

ich weiß zwar, dass da schon mal ein Thread war, aber ob das noch so ist ...? Hier im Beispiel waren die Leerzeichen überall drin ...

[Kuwer]

Hallo,

hier eine Arrayvariante:

Option Explicit

Sub WerteTrennenMitFeldvariablen_Uwe()
  Dim lngSpalte As Long, lngZeileQ As Long, lngZeileZ As Long
  Dim lngBauteile As Long, lngLetzteZeile As Long
  Dim varBauteile As Variant, varQ As Variant, varZ As Variant
  
  'letzte belegte Zeile in Spalte A (1)
  lngLetzteZeile = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
  
  'Tabelle in Variable einlesen
  varQ = Range("A7:J" & lngLetzteZeile).Value
  
  'Schleife für Bauteilesummierung
  For lngZeileQ = 1 To UBound(varQ)
    If Not IsNumeric(varQ(lngZeileQ, 7)) Or varQ(lngZeileQ, 7) = "" Then varQ(lngZeileQ, 7) = 1
    lngBauteile = lngBauteile + varQ(lngZeileQ, 7)
    varQ(lngZeileQ, 7) = 1
  Next lngZeileQ
  
  'Variable für die Rückgabe entsprechend der Bauteileanzahl dimensionieren
  ReDim varZ(1 To lngBauteile, 1 To UBound(varQ, 2))
  
  'Schleife für das Umschaufeln der Daten
  For lngZeileQ = 1 To UBound(varQ)
    varBauteile = Split(varQ(lngZeileQ, 3), ",")
    For lngBauteile = 0 To UBound(varBauteile)
      lngZeileZ = lngZeileZ + 1
      varZ(lngZeileZ, 1) = lngZeileZ
      varZ(lngZeileZ, 2) = varQ(lngZeileQ, 2)
      varZ(lngZeileZ, 3) = Trim(varBauteile(lngBauteile))
      For lngSpalte = 4 To UBound(varZ, 2)
        varZ(lngZeileZ, lngSpalte) = varQ(lngZeileQ, lngSpalte)
      Next lngSpalte
    Next lngBauteile
  Next lngZeileQ
  
  'Tabelle und weiter bis letzte Zeile löschen
  Cells(7, 1).Resize(Rows.Count - 6, UBound(varZ, 2)).Delete Shift:=xlUp

  'Zurückschreiben der Zielvariable in Tabelle
  With Cells(7, 1).Resize(UBound(varZ, 1), UBound(varZ, 2))
    .Value = varZ
    .EntireColumn.AutoFit
  End With
End Sub

Code eingefügt mit: Excel Code Jeanie

Autofit braucht nicht wirklich viel Zeit.

Gruß Uwe

[Rabe]

Hi,

ich weiß zwar, dass da schon mal ein Thread war, aber ob das noch so ist ...? Hier im Beispiel waren die Leerzeichen überall drin ...

ich würde es gerne drin lassen, da ich nicht weiß, ob nicht doch jemand eine Stückliste erstellt, wo keine " " drin sind.