Text 600x kopieren mit variablen Textteilen

Sub AutofilterProdukt_AAI() Application.ScreenUpdating = False Dim col% col = Rows(3).Range("zProdukt").column Selection.AutoFilter Field:=col, Criteria1:"*AAI*" Call FilterzelleAktiv_Produkt Call LetzteZeile_in_SpalteA_EingabeACN Application.ScreenUpdating = True If Cells(Rows.Count, 1).End(xlUp).row = 1 Then MsgBox "Filter leer!" End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Kopieren600() On Error GoTo Fehler Dim i%, Z1$, Z5$ Dim LR1%, LR2% Application.ScreenUpdating = False With ActiveSheet Z1 = Left(.Cells(1, 2), 22) Z5 = Left(.Cells(5, 2), 53) LR1 = .Cells(Rows.Count, 1).End(xlUp).Row 'letzte Zeile der Spalte A For i = 2 To LR1 LR2 = .Cells(Rows.Count, 2).End(xlUp).Row + 1 .Cells(LR2, 2) = Z1 & .Cells(i, 1) & "()" LR2 = LR2 + 1 .Range(Cells(2, 2), Cells(4, 2)).Copy Cells(LR2, 2) LR2 = LR2 + 3 .Cells(LR2, 2) = Z5 & .Cells(i, 1) & "*""" LR2 = LR2 + 1 .Range(Cells(6, 2), Cells(10, 2)).Copy Cells(LR2, 2) Next End With '*** Fehlerbehandlung Err.Clear Fehler: If Err.Number 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear End Sub

Sub AutofilterProdukt(sProdukt As String) Dim col% Application.ScreenUpdating = False col = Rows(3).Range("zProdukt").Column Selection.AutoFilter Field:=col, Criteria1:="*" & sProdukt & "*" Call FilterzelleAktiv_Produkt Call LetzteZeile_in_SpalteA_EingabeACN Application.ScreenUpdating = True If Cells(Rows.Count, 1).End(xlUp).Row = 1 Then MsgBox "Filter leer!" End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Select Case Target.Column Case 1 If Target "" Then AutofilterProdukt Target Cancel = True End If End If Case 2, 10 'x in B oder J Cancel = True End Select End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Select Case Target.column Case 1 If Intersect(Target, Range("B:B")) Is Nothing Then Exit Sub 'If Intersect(Target, _ Range("J:J")) Is Nothing Then Exit Sub If Len(Target.Cells(1)) = 0 Then Target.Cells(1) = "x" Else Target.Cells(1) = vbNullString End If Cancel = True Case 2, 10 If Intersect(Target, Range("J:J")) Is Nothing Then Exit Sub 'If Intersect(Target, _ Range("J:J")) Is Nothing Then Exit Sub If Len(Target.Cells(1)) = 0 Then Target.Cells(1) = "x" Else Target.Cells(1) = vbNullString End If Cancel = True Case 3, 20 If Target.column = 7 Then If Target "" Then Autofilter_Produkt Target Cancel = True End If End If Case 4, 30 If Target.column = 8 Then If Target "" Then Autofilter_Aufmachung Target Cancel = True End If End If Case 5, 40 If Target.column = 9 Then If Target "" Then Autofilter_NP_FS Target Cancel = True End If End If End Select End Sub

Sub Kopieren_ButtonAufmachung() On Error GoTo Fehler Dim i%, Z1$, Z5$ Dim LR1%, LR2% Application.ScreenUpdating = False With ActiveSheet Z1 = Left(.Cells(1, 2), 22) Z5 = Left(.Cells(5, 2), 54) LR1 = .Cells(Rows.Count, 1).End(xlUp).Row 'letzte Zeile der Spalte A For i = 2 To LR1 LR2 = .Cells(Rows.Count, 2).End(xlUp).Row + 1 .Cells(LR2, 2) = Z1 & .Cells(i, 1) & "()" LR2 = LR2 + 1 .Range(Cells(2, 2), Cells(4, 2)).Copy Cells(LR2, 2) LR2 = LR2 + 3 .Cells(LR2, 2) = Z5 & .Cells(i, 1) & "*""" LR2 = LR2 + 1 .Range(Cells(6, 2), Cells(10, 2)).Copy Cells(LR2, 2) Next End With '*** Fehlerbehandlung Err.Clear Fehler: If Err.Number 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear End Sub

Sub Kopieren600_SpalteC() On Error GoTo Fehler Dim i%, Z2$, Z3$ Dim LR1%, LR3% Application.ScreenUpdating = False With ActiveSheet Z2 = Left(.Cells(2, 3), 12) Z3 = Left(.Cells(3, 3), 24) LR1 = .Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To LR1 LR3 = .Cells(Rows.Count, 3).End(xlUp).Row + 1 .Cells(1, 3).Copy .Cells(LR3, 3) LR3 = LR3 + 1 .Cells(LR3, 3) = Z2 & .Cells(i, 1) & """" LR3 = LR3 + 1 .Cells(LR3, 3) = Z3 & .Cells(i, 1) & """" LR3 = LR3 + 1 .Range(Cells(4, 3), Cells(5, 3)).Copy Cells(LR3, 3) Next End With Err.Clear Fehler: If Err.Number 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear End Sub

Sub Autofilter_AAI()AAI_36() Application.ScreenUpdating = False Dim col% col = Rows(3).Range("zAufmachung").column Selection.AutoFilter Field:=col, Criteria1:="AAI_36*" FilterzelleAktiv_Darreichungsform Call LetzteZeile_in_SpalteA_EingabeACN Application.ScreenUpdating = True Call FilterMsgBox_FilterLeer End Sub

Sub Kopieren_AutofilterAufmachung() On Error GoTo Fehler Dim i%, Z1$, Z5$ Dim LR1%, LR2% Application.ScreenUpdating = False With ActiveSheet Z1 = Left(.Cells(1, 2), 22) Z5 = Left(.Cells(5, 2), 54) LR1 = .Cells(Rows.Count, 1).End(xlUp).Row 'letzte Zeile der Spalte A For i = 2 To LR1 LR2 = .Cells(Rows.Count, 2).End(xlUp).Row + 1 .Cells(LR2, 2) = Z1 & .Cells(i, 1) & "()" LR2 = LR2 + 1 .Range(Cells(2, 2), Cells(4, 2)).Copy Cells(LR2, 2) LR2 = LR2 + 3 .Cells(LR2, 2) = Z5 & .Cells(i, 1) & "*""" LR2 = LR2 + 1 .Range(Cells(6, 2), Cells(10, 2)).Copy Cells(LR2, 2) Next End With '*** Fehlerbehandlung Err.Clear Fehler: If Err.Number 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear End Sub

Ok. Hier mal die Zeilen erklärt.
Du musst dann z.B.


Z2 = Left(.Cells(2, 2), xx)
Z3 = Left(.Cells(3, 2), zz)

ermitteln
und später dann = mit & zusammenbauen

Sub Kopieren600()
On Error GoTo Fehler '00
Dim i%, Z1$, Z5$ '01
Dim LR1%, LR2% '02
Application.ScreenUpdating = False '03
With ActiveSheet '04
Z1 = Left(.Cells(1, 2), 22) '05
Z5 = Left(.Cells(5, 2), 54) '06
LR1 = .Cells(Rows.Count, 1).End(xlUp).Row '07
For i = 2 To LR1 '08
LR2 = .Cells(Rows.Count, 2).End(xlUp).Row + 1 '09
.Cells(LR2, 2) = Z1 & .Cells(i, 1) & "()" '10
LR2 = LR2 + 1 '11
.Range(Cells(2, 2), Cells(4, 2)).Copy Cells(LR2, 2) '12
LR2 = LR2 + 3 '13
.Cells(LR2, 2) = Z5 & .Cells(i, 1) & "*""" '14
LR2 = LR2 + 1 '15
.Range(Cells(6, 2), Cells(10, 2)).Copy Cells(LR2, 2) '16
Next '17
End With '18
'*** Fehlerbehandlung
Err.Clear
Fehler:
If Err.Number  0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err. _
Description: Err.Clear
End Sub
' 00 setzt die Fehlerbehandlung
' 01 und 02 reservieren/ festlegen der Variablen
' 03 Macht den Code schneller, da die Bildschirmaktuialisiereung erst zum Schluss erfolgt
' 04 Spart Schreibarbeit, alles innerhalb der With Anweisung
' 05 Variabler Teil der Zeile 1 Z1, nur die ersten 22 Zeichen
' 06 Variabler Teil der Zeile 5 Z5, nur die ersten 54 Zeichen (inkl. der Leerzeichen am Anfang)
' 07 letzte Zeile aus Spalte A
' 08 Schleife von 2 bis Ende Spalte A
' 09 Erste freie Zeile in Spalte B (im ersten Durchlauf =11)
' 10 setzt in Zelle B11 den Text zusammen: Z1, dahinter Inhalt aus A2, dahinter noch die ()
' 11 Neue erste Freie Zeile liegt jetzt eins tiefer, Also in B12
' 12 Kopiert Zelle B2 bis B4 in B11       >>> Cells(Zeile, Spalte)
' 13 Neue erste Freie Zeile liegt jetzt 3 tiefer, Also in B15
' 14 setzt in B15 den Text zusammen: Z5, dahinter Inhalt aus A2, dahinter noch * und "
'         " innnerhalb von Anführungszeichen müssen doppelt angegeben werden; deshalb hinten 3x
' 15 Neue erste Freie Zeile liegt jetzt eins tiefer, Also in B16
' 16 Kopiert Zelle B6 bis B10 in B16
' 17 Nächster Wert aus Spalte A
' 18 Ende der With Anweisung
' 19... Fehlerbehandlung

Gruß Uwe

Private Sub Workbook_Open() With Sheets("Tabelle2") Sheets("Tabelle1").ComboBox1.List = _ .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp)).Value End With With Sheets("Tabelle1").ComboBox1 .MatchRequired = True .MatchEntry = 1 End With End Sub

Sub AutofilterProdukt(ByVal sProdukt As String) Dim col% Application.ScreenUpdating = False col = Rows(3).Range("zProdukt").Column Selection.AutoFilter Field:=col, Criteria1:="*" & sProdukt & "*" Call FilterzelleAktiv_Produkt Call LetzteZeile_in_SpalteA_EingabeACN Application.ScreenUpdating = True If Cells(Rows.Count, 1).End(xlUp).Row = 1 Then MsgBox "Filter leer!" End Sub

Beliebteste Forumthreads (12 Monate)

Text 600x kopieren mit variablen Textteilen

23
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Text 600x kopieren mit variablen Textteilen

23 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

23
Beiträge zum Forumthread

Beiträge zu diesem Forumthread