AW: Kopieren aus anderer Datei
17.12.2013 15:22:50
fcs
Hallo Raffa,
hier ein Beispiel wie man es umsetzen kann.
Hier werden jeweils alle Daten aus der Zeile im Journal in die Zieltabelle kopiert.
Gruß
Franz
Sub MakeSheetsForCodes()
Dim wksPL As Worksheet
Dim Zeile As Long, ZeileL As Long
With ActiveWorkbook
Set wksPL = .Worksheets("P&L")
With wksPL
ZeileL = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
For Zeile = 2 To ZeileL
.Worksheets.Add after:=.Sheets(.Sheets.Count)
.Sheets(.Sheets.Count).Name = wksPL.Cells(Zeile, 1).Text
Next
End With
End Sub
Sub GetData_from_Journal()
Dim wkbTemplate As Workbook
Dim wksJournal As Worksheet, wksPL As Worksheet, wksCode As Worksheet
Dim Zeile As Long, ZeileL As Long, Zeile_Z As Long
Dim rngCode As Range, rngSearch_R As Range, rngSearch_S As Range
Dim strAddress1 As String, varCode
Set wkbTemplate = Workbooks("Template.xlsm") 'ActiveWorkbook
Set wksJournal = Workbooks("Journal Analysis.csv").Sheets(1)
Set wksPL = wkbTemplate.Worksheets("P&L")
With wksPL
'Letzte Zeile in Code-Liste Spalte A
ZeileL = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
'Zu durchsuchende Zellbereiche im Journal Analyse
With wksJournal
Set rngSearch_R = .Range(.Cells(1, 18), .Cells(.Rows.Count, 18).End(xlUp))
Set rngSearch_S = .Range(.Cells(1, 19), .Cells(.Rows.Count, 19).End(xlUp))
End With
'Codes im Blatt "P&L" abarbeiten
For Zeile = 2 To ZeileL
varCode = wksPL.Cells(Zeile, 1).Text
'Zieltabelle setzen
Set wksCode = wkbTemplate.Worksheets(varCode)
'Letzte Zeile mit Daten im Zielblatt ermiteln
With wksCode
Set rngCode = .Cells.Find(what:="*", after:=.Cells(1, 1), LookIn:=xlFormulas, _
lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious)
If rngCode Is Nothing Then
Zeile_Z = 0
Else
Zeile_Z = rngCode.Row
End If
End With
'Code in Spalte R des Journals suchen
Set rngCode = rngSearch_R.Find(what:=varCode, LookIn:=xlValues, lookat:=xlWhole)
If rngCode Is Nothing Then
'Code in Spalte S des Journals suchen
Set rngCode = rngSearch_S.Find(what:=varCode, LookIn:=xlValues, lookat:=xlWhole)
If rngCode Is Nothing Then
'do nothing - Code im Journal nicht vorhanden
Else
'1, Fundstelle merken
strAddress1 = rngCode.Address
Do
'Daten aus dem Journal ins Zielblatt kopieren
Zeile_Z = Zeile_Z + 1
Call prcCopyData(wksQuelle:=wksJournal, ZeileQ:=rngCode.Row, _
wksZiel:=wksCode, ZeileZ:=Zeile_Z)
'nächste Zeile mit Code suchen
Set rngCode = rngSearch_S.FindNext(after:=rngCode)
Loop Until rngCode.Address = strAddress1
End If
Else
'1, Fundstelle merken
strAddress1 = rngCode.Address
Do
'Daten aus dem Journal ins Zielblatt kopieren
Zeile_Z = Zeile_Z + 1
Call prcCopyData(wksQuelle:=wksJournal, ZeileQ:=rngCode.Row, _
wksZiel:=wksCode, ZeileZ:=Zeile_Z)
'nächste Zeile mit Code suchen
Set rngCode = rngSearch_R.FindNext(after:=rngCode)
Loop Until rngCode.Address = strAddress1
End If
Next
End Sub
Private Sub prcCopyData(ByVal wksQuelle As Worksheet, ByVal ZeileQ As Long, _
ByVal wksZiel As Worksheet, ByVal ZeileZ As Long)
'Daten kopieren
With wksQuelle
.Range(.Cells(ZeileQ, 1), .Cells(ZeileQ, .Columns.Count).End(xlToLeft)).Copy _
Destination:=wksZiel.Cells(ZeileZ, 1)
End With
End Sub