Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1172to1176
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Code Anpassung Export

Code Anpassung Export
Maris
Hi liebe VBA Cracks,
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

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Code Anpassung Export
24.08.2010 11:13:02
Maris
Hat jemand eine Lösung oder ist besser einen anderen Code zu verwenden?
Bitte schön...
24.08.2010 13:35:31
Marc

Sub export()
Dim ArrayÜberschrift(1 To 79) As Variant, ArrayWerte() As Variant 'Dim ArrayÜberschrift(1 To  _
33)
Dim x As Long, z As Long
Dim i As Long, y As Long, lngSpalte As Long
Dim rSuche As Range, rFinde As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
.ActiveSheet.Unprotect
End With
Workbooks.Open Filename:="C:\Users\cmazilu\Arbeitsumgebung\Testing\Input.xlsx" ' Hier  Pfad  _
anpassen z.B.Filename:="C: _
'ziel_löschen
ThisWorkbook.Activate
For i = 1 To 79
ArrayÜberschrift(i) = ThisWorkbook.Sheets("Tabelle1").Cells(1, i + 1) '+29
Next i
With Workbooks("Input.xls").Sheets("Tabelle1")
lz = ThisWorkbook.Sheets("Tabelle1").Cells(Rows.Count, "c").End(xlUp).Row 'sucht die  _
letzte benutzte Zeile in Spalte C
lz_input = .Cells(Rows.Count, "c").End(xlUp).Row 'sucht die letzte benutzte Zeile in  _
Spalte C
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 lz
If ThisWorkbook.Sheets("Tabelle1").Cells(x, i + 1).EntireRow.Hidden = False  _
Then
ReDim Preserve ArrayWerte(y)
ArrayWerte(y) = ThisWorkbook.Sheets("Tabelle1").Cells(x, i + 1)
y = y + 1
End If
Next x
lngSpalte = rSuche.Column
For z = LBound(ArrayWerte()) To UBound(ArrayWerte())
.Cells(lz_input + z, lngSpalte) = ArrayWerte(z)
If IsDate(ArrayWerte(z)) Then
.Cells(lz_input + z, lngSpalte) = Format(ArrayWerte(z), "dd.mm.yyyy")
Else
.Cells(lz_input + 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
End Sub

Anzeige
AW: Bitte schön...
24.08.2010 17:41:37
Maris
Super vielen lieben Danke für die Anpasssung! Klappt alles wunderbar :-) Sogar das Datumsformat wird beibehalten.. hurra. Eine Kleinigkeit geht allerdings schief... leider werden die Überschriften überschrieben in der input Datei... damit ist ein neuer Export leider nicht mehr möglich :-(
Würde mich sehr freuen wenn du mir noch kurz weiterlefen kannst.
Gruß
Maris
AW: Bitte schön...
25.08.2010 07:19:33
Marc

Sub export()
Dim ArrayÜberschrift(1 To 79) As Variant, ArrayWerte() As Variant 'Dim ArrayÜberschrift(1 To  _
33)
Dim x As Long, z As Long
Dim i As Long, y As Long, lngSpalte As Long
Dim rSuche As Range, rFinde As Range
With Application
'.ScreenUpdating = False 'geänderte Daten werden nicht dargestellt, Bilschirm wird nicht  _
aktualisiert
.EnableEvents = False
.ActiveSheet.Unprotect
End With
Application.Windows.Arrange ArrangeStyle:=xlArrangeStyleTiled
Workbooks.Open Filename:="C:\Users\cmazilu\Arbeitsumgebung\Testing\Input.xlsx" ' Hier  Pfad  _
anpassen z.B.Filename:="C: _
'ziel_löschen
Application.Windows.Arrange ArrangeStyle:=xlArrangeStyleTiled 'Fenster werden geteilt  _
dargestellt
ThisWorkbook.Activate
For i = 1 To 79
ArrayÜberschrift(i) = ThisWorkbook.Sheets("Tabelle1").Cells(1, i + 1) '+29
Next i
With Workbooks("Input.xls").Sheets("Tabelle1")
lz = ThisWorkbook.Sheets("Tabelle1").Cells(Rows.Count, "c").End(xlUp).Row 'sucht die  _
letzte benutzte Zeile in Spalte C
lz_input = .Cells(Rows.Count, "c").End(xlUp).Row 'sucht die letzte benutzte Zeile in  _
Spalte C
Min = 6 'es wird erst in der 7. Reihe begonnen.
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 lz
If ThisWorkbook.Sheets("Tabelle1").Cells(x, i + 1).EntireRow.Hidden = False  _
Then
ReDim Preserve ArrayWerte(y)
ArrayWerte(y) = ThisWorkbook.Sheets("Tabelle1").Cells(x, i + 1)
y = y + 1
End If
Next x
lngSpalte = rSuche.Column
For z = LBound(ArrayWerte()) To UBound(ArrayWerte())
.Cells(lz_input + z + Min, lngSpalte) = ArrayWerte(z)
'Unnötig?
'                    If IsDate(ArrayWerte(z)) Then
'                        .Cells(lz_input + z, lngSpalte) = Format(ArrayWerte(z), "dd.mm.yyyy")
'                    Else
'                        .Cells(lz_input + 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
End Sub

Anzeige
AW: Bitte schön...
25.08.2010 10:52:52
Maris
Hi Marc,
'Unnötig?
' If IsDate(ArrayWerte(z)) Then
' .Cells(lz_input + z, lngSpalte) = Format(ArrayWerte(z), "dd.mm.yyyy")
' Else
' .Cells(lz_input + z, lngSpalte) = ArrayWerte(z)
' End If
in der Tat, diese Prozedur ist unnötig!
Danke Dir!
Gruß,
Maris
Format der Zellen
27.08.2010 07:07:47
Marc
Mir ist allerdings aufgefallen, das das Format nicht mit übertragen wird. Das Datum wird automatisch erkannt, aber die rote schrift und das durchgestrichene werden nicht betrachtet!
Gruß, Marc
Anzeige
AW: Format der Zellen
27.08.2010 10:55:29
Maris
stimmt die Formate werden nicht mitübertragen. Allerdings ist es mir nur sehr wichtig das die Datumsformate richtig übertragen werden. Das Durchgestrichene und die rote Einfärbung sind bedingte Formatierungen...
Ein Prob verbleibt allerdings :-( Der export dauert unglaublich lange... An was mag das wohl liegen? Kann man da was optimieren?
Gruß
Chris

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige