ich habe mal wieder ein Problem:
folgender Code wurde mir hier zur Verfügung gestellt und funktioniert auch:
Private Sub CommandButton1_Click()
Dim lRow As Long
Dim sRow As Long
Dim myWks As String
Dim wkbZiel As Workbook, wksZiel As Worksheet
Dim wksQuelle As Worksheet
Set wksQuelle = ActiveSheet
'Ursprungstabelle: Daten kopieren
myWks = Range("B" & Selection.Row).Value
Selection.Copy
sRow = Selection.Row
On Error Resume Next
Set wkbZiel = Workbooks("INFOBOX_FICO_test.xlsm")
On Error GoTo 0
If wkbZiel Is Nothing Then
Set wkbZiel = Workbooks.Open("c:\test\INFOBOX_FICO_test.xlsm") 'anpassen
End If
Set wksZiel = wkbZiel.Sheets(myWks)
'Bildschirmaktualisierung und Ereignismakros deaktivieren
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
With wksZiel
'letzte freie Zeile der Zieltabelle finden
lRow = .Cells(Rows.Count, 2).End(xlUp).Row + 1
'Ursprungsdatensatz einfügen
.Range("K" & lRow).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
'String-Zerteilungs Formeln einfügen
.Range("B" & lRow).FormulaR1C1 = "=LEFT(RC[9],13)"
.Range("C" & lRow).FormulaR1C1 = "=MID(RC[8],15,9^9)"
.Range("G" & lRow).FormulaR1C1 = "=MID(RC[4],15,2)"
.Range("H" & lRow).FormulaR1C1 = "=RIGHT(RC[3],3)"
.Range("B" & lRow & ":H" & lRow).Value = .Range("B" & lRow & ":H" & lRow).Value
.Columns("K:K").ClearContents
End With
'Transaktionen kopieren
wksQuelle.Range("D" & sRow).Copy
wksZiel.Range("F" & lRow).PasteSpecial Paste:=xlValues
'Testart kopieren
wksQuelle.Range("E" & sRow).Copy
wksZiel.Range("D" & lRow).PasteSpecial Paste:=xlValues
wkbZiel.Close True
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Der Code leistet folgendes: Nach Markieren einer Zelle in Spalte C der Quelltabelle und klicken auf einen Button werden die Daten der Spalten C, D und E der Quelltabelle in die Zielmappe übertragen, und zwar in das Tabellenblatt der Zielmappe, das die gleiche Benamung besitzt wie in Spalte B der Quelltabelle eingetragen ist. Dabei werden die Daten aus Spalte C der Quelle in der Zieltabelle gesplittet auf verschiedene Salten. Die Zieltabelle öffnet und schließt automatisch im Hintergrund.
Meine Frage ist, ob man diesen Code folgendermaßen erweitern kann:
In der Quelltabelle wurden nachträglich folgende Spalten eingefügt :
L M N O P Q
Debitoren Kreditoren Artikel Profitcenter Kostenstelle Innenauftrag
außerdem gibt es eine Spalte D "Transaktionen".
In der Zielmappe gibt es ein Tabellenblatt "TA und Stammdaten" mit den Spalten
A B C D E F G
Transaktionen Debitoren Kreditoren Artikel Profitcenter Kostenstelle Innenauftrag
Jetzt soll obiger Code so geändert werden, daß die Einträge aus der Quelltabelle (Spalten D, L - Q) in das Tabellenblatt "TA und Stammdaten" der Zielmappe vor deren automatischem Schließen entsprechend der Spaltenüberschriften übertragen werden. Dabei gibt es bei Spalte D "Transaktionen" noch folgendes zu beachten:
In der Quellzelle (z.Bsp. D3) können unter Umständen mehrere Transaktionen stehen , die in der Zieltabelle getrennt sein sollen (z.Bsp. A3 und A4). Das Problem ist, daß die Transaktionsbezeichnungen unterschiedliche Länge haben. Aber vor und nach jeder Transaktionsbezeichnung steht ein blank. Sonst sind keine blanks vorhanden.
Nachfolgender Code wurde mir hier schon einmal zur Verfügung gestellt (der aber separat abläuft, dabei nur die Spalte D "Transaktionen" behandelt und innerhalb der Zielmappe von einem Blatt zum anderen kopiert, das aber wie oben beschrieben geändert werden soll):
Sub TransaktListeMark() ' bearbeitet markierte Zellen in Spalte D
Dim MyDic, Kys, arrNot, lngA As Long, ii As Long
Dim arrW, arrT, zz As Long, tt As Long
arrNot = Split("+?+ + ?( /oder/ / ) ", " ")
lngA = UBound(arrNot)
Set MyDic = CreateObject("Scripting.Dictionary")
With Sheets("TA und Stammdaten") ' bisherige Transakt.
zz = .Cells(.Rows.Count, 1).End(xlUp).Row
If zz > 1 Then
arrW = .Cells(2, 1).Resize(zz - 1)
For zz = 1 To UBound(arrW)
On Error Resume Next
MyDic.Add arrW(zz, 1), 1
On Error GoTo 0
Next zz
End If
End With
With Sheets("GSZ_OP_TA_BSP") ' neue Transakt.
.Activate
arrW = Intersect(.Columns(6), Selection)
For zz = 1 To UBound(arrW)
arrT = Split(arrW(zz, 1), " ")
For tt = 0 To UBound(arrT)
For ii = 0 To lngA
If arrT(tt) = arrNot(ii) Then Exit For
Next ii
If ii > lngA Then
On Error Resume Next
MyDic.Add arrT(tt), 1
On Error GoTo 0
End If
Next tt
Next zz
End With
Kys = MyDic.Keys ' Ausgabe Transakt.
Sheets("TA_Liste").Cells(2, 1).Resize(MyDic.Count) = _
Application.Transpose(Kys)
Set MyDic = Nothing
End Sub
Ich hoffe ich habe mich verständlich ausgedrückt. Kann mir hierbei jemand helfen?
Viele Grüße
Stefan