ich habe hier noch einen code zum Export von Daten in eine andere Datei. Habe bislang vergeblich versucht ihn selbst anzupassen, leider ohne Erfolg es findet leider kein Export statt.
Die Importdatei hat den selben Aufbau nur ohne Daten! Ganz wichtig ist, was bei diesem Code nicht geprüft wird ist das die Daten immer angefügt werden sollen. Die Spalte B ist dabei die Spalte mit dem letzten Zeilenwert. Wieterhin habe ich in verschieden Spalten Formate wie Datum oder Währung... diese sollen auch mit übertragen werden. Hier nun der Code und anschließend die Beispieldatei:
Sub export()
Dim ArrayÜberschrift(1 To 79) 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 = True
With Application
.ScreenUpdating = False
.EnableEvents = False
.ActiveSheet.Unprotect
End With
Workbooks.Open Filename:="C:\Users\user1\Arbeitsumgebung\\input.xls"
ThisWorkbook.Activate
For i = 1 To 79
ArrayÜberschrift(i) = ThisWorkbook.Sheets("Tabelle1").Cells(1, i + 1)
Next i
With Workbooks("input.xls").Sheets("Tabelle1")
Set rFinde = .Range("A1:CA1")
For i = 1 To 79
Set rSuche = rFinde.Find(what:=ArrayÜberschrift(i), LookAt:=xlWhole, LookIn:= _
xlValues)
If Not rSuche Is Nothing Then
For x = 2 To 2000
If ThisWorkbook.Sheets("Tabelle1").Cells(x, i + 1).EntireRow.Hidden = False _
Then
ReDim Preserve ArrayWerte(y)
ArrayWerte(y) = ThisWorkbook.Sheets("bericht").Cells(x, i + 1)
y = y + 1
End If
Next x
lngSpalte = rSuche.Column
For z = LBound(ArrayWerte()) To UBound(ArrayWerte())
.Cells(6 + z, lngSpalte) = ArrayWerte(z)
If IsDate(ArrayWerte(z)) Then
.Cells(6 + z, lngSpalte) = Format(ArrayWerte(z), "dd.mm.yyyy")
Else
.Cells(6 + z, lngSpalte) = ArrayWerte(z)
End If
Next z
End If
ReDim ArrayWerte(0)
y = 0
Next i
End With
Workbooks("input.xls").Save
Workbooks("input.xls").Close
Set rSuche = Nothing
Set rFinde = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
.ActiveSheet.Protect
End With
Application.ScreenUpdating = True
End Sub
https://www.herber.de/bbs/user/71206.xls
Vielen lieben Dank!
Gruß,
Maris