Daten kopieren nach Kriterium kopieren

Hi allerseits,
isch habe zwei excel dateien(exportdatei und importdatei) deren Spalten die gleichen Überschriften haben, jedoch und jetzt kommen die Probleme:
- die exportdatei enthält nich alle Spaltenüberschrift jedoch ist die Bezeichnung identisch
- In der exportdatei stehen die Werte in den Spalten AD:BD und den Zeilen 241:307 die müssen auch fix bleiben. in der Importdatei gehts bei A los und zeile 6
- in diesem Bereich ändere ich die Zeilenanzahl per Makro durch beim export sollen immer nur die eingeblendeten Werte (also nicht Formate oder Formeln) übertragen werden...
- das Makro soll nun die eingeblendeten Spalten vergleichen und in der Importdatei einfügen, die Datei speichern und schliessen.
Kann mir jemand bei diesem komplexen Problem helfen?
Anbei die entsprechenden Datei zur Veranschaulichung...
Export Datei!
https://www.herber.de/bbs/user/53539.xls
Import Datei!
https://www.herber.de/bbs/user/53540.xls
Thanks an alle scho mal
Gruß
Maris

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub schreib() Dim ArrayÜberschrift(1 To 27) As Variant, ArrayWerte() As Variant Dim x As Long, z As Long Dim i As Long, y As Long, lngSpalte As Long Dim rSuche As Range, rFinde As Range For i = 1 To 27 ArrayÜberschrift(i) = Cells(240, i + 29) Next i With Workbooks("Ziel.xls").Sheets("LedgerJournalTrans") Set rFinde = .Range("A1:CM1") For i = 1 To 27 Set rSuche = rFinde.Find(what:=ArrayÜberschrift(i), LookAt:=xlWhole, LookIn:=xlValues) If Not rSuche Is Nothing Then For x = 241 To 307 If Cells(x, i + 29).EntireRow.Hidden = False Then ReDim Preserve ArrayWerte(y) ArrayWerte(y) = Cells(x, i + 29) y = y + 1 End If Next x lngSpalte = rSuche.Column For z = LBound(ArrayWerte()) To UBound(ArrayWerte()) .Cells(6 + z, lngSpalte) = ArrayWerte(z) Next z End If ReDim ArrayWerte(0) y = 0 Next i End With Workbooks("Ziel.xls").Save Workbooks("Ziel.xls").Close Set rSuche = Nothing Set rFinde = Nothing End Sub

Servus Maris,
wenn der Pfad immer gleich ist, dann so:
Option Explicit


Sub schreib()
Dim ArrayÜberschrift(1 To 27) As Variant, ArrayWerte() As Variant
Dim x As Long, z As Long
Dim i As Long, y As Long, lngSpalte As Long
Dim rSuche As Range, rFinde As Range
Application.ScreenUpdating = False
Workbooks.Open Filename:=ThisWorkbook.Path & "\Ziel.xls" ' Hier  Pfad anpassen z.B.Filename:="C: _
ThisWorkbook.Activate
For i = 1 To 27
ArrayÜberschrift(i) = ThisWorkbook.Sheets("bericht").Cells(240, i + 29)
Next i
With Workbooks("Ziel.xls").Sheets("LedgerJournalTrans")
Set rFinde = .Range("A1:CM1")
For i = 1 To 27
Set rSuche = rFinde.Find(what:=ArrayÜberschrift(i), LookAt:=xlWhole, LookIn:=xlValues)
If Not rSuche Is Nothing Then
For x = 241 To 307
If ThisWorkbook.Sheets("bericht").Cells(x, i + 29).EntireRow.Hidden = False  _
Then
ReDim Preserve ArrayWerte(y)
ArrayWerte(y) = ThisWorkbook.Sheets("bericht").Cells(x, i + 29)
y = y + 1
End If
Next x
lngSpalte = rSuche.Column
For z = LBound(ArrayWerte()) To UBound(ArrayWerte())
.Cells(6 + z, lngSpalte) = ArrayWerte(z)
Next z
End If
ReDim ArrayWerte(0)
y = 0
Next i
End With
Workbooks("Ziel.xls").Save
Workbooks("Ziel.xls").Close
Set rSuche = Nothing
Set rFinde = Nothing
Application.ScreenUpdating = True
End Sub

Gruß
Chris

Beliebteste Forumthreads (12 Monate)

Daten kopieren nach Kriterium kopieren

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread