Auslesen einer Datei und schreiben in Neue

Moin Leute
ich habe gedacht, das eure bisherige Hilfe
(Ich danke an dieser Stelle noch einmal dafür)
ausreicht um mit dem Problem fertig zu werden. Leider habe ich mich geirrt.
Ich beschreibe mal das Problem.
Ich habe die Datei "001" = Das ist die Zieldatei
Die Arbeitsdateien sind 002,003 usw.
Diese werden täglich befüllt und dann in 001 zusammengetragen.
Jede Datei enthält ein Sheet "Eingabe"
Jedes Sheet eine dynamische Tabelle mit Namen Tabelle(Dateiname ohne Nullen)
- Beispiel: (Datei= 001 / Sheet= "Eingabe" / dynamische Tabelle= Tabelle1) USW.
Ich möchte nun aus allen Dateien größer 001 die dynamische Tabelle auslesen,
diese an das untere Ende der Tabelle von 001 kopieren, die Kopierte Tabelle löschen,
aus der Headline von Tabelle1 eine neue Tabelle generieren,
die Datei speichern und schließen.
Beispiel:
Öffne 002 - kopiere Tabelle2 an das untere Ende von Tabelle1 in Datei 001.
Lösche Tabelle2, generiere Tabelle2 aus Tabelle1 neu , Speicher 002 und schließen
Zwei Dinge sind nun zu beachten.
1. Das Makro muss selber prüfen wieviele Dateien es überhaupt gibt.
- Ich hoffe das geht, da diese ja fortlaufend nummeriert sind.
2. die Tabellengröße ist variabel in Länge und Breite.
- Es wäre schön wenn die Tabelle aus 001 neu in das entsprechende Sheet als dynamische Tabelle kopiert werden kann um so sicherzustellen, das spätere Änderungen mit der Eingabe am nächsten Tag übernommen werden.
Kann mir da jemand wohl bei helfen?
Das wäre wirklich super.
Was ich bisher habe ich nämlich wirklich wenig.
Liebe Grüße
Steve

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub TEST() Dim strPfad As String strPfad = ThisWorkbook.Path Workbooks.Open strPfad & "\002.xlsx" Range("Tabelle2").Copy Windows("001.xlsm").Activate Range("Tabelle1[[LFSNR ]]").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Windows("002.xlsx").Activate Application.CutCopyMode = False Range("Tabelle2").Delete Shift:=xlUp ActiveWorkbook.Save ActiveWindow.Close End Sub

Hallo,
kannst mal diese Variante versuchen.
Code kommt in die Datei 001.xlsm oder 001.xls

Option Explicit
Option Compare Text
Sub Start()
Dim sPath$, sDir$, sTabName$
Dim ArFiles(), i%, j%
Dim booSave As Boolean
Dim rngData As Range, rngZiel As Range, oWS As Worksheet
'Pfad wo die Dateien liegen mit \ am ende
sPath = ThisWorkbook.Path
sPath = sPath & IIf(Right$(sPath, 1)  "\", "\", "")
'Dateien suchen
sDir = Dir$(sPath & "?.xls?", vbNormal)
Do While sDir  ""
If sDir  ThisWorkbook.Name Then
If IsNumeric(Left$(sDir, InStrRev(sDir, ".") - 1)) Then
ReDim Preserve ArFiles(i)
ArFiles(i) = sPath & sDir
i = i + 1
End If
End If
sDir = Dir$()
Loop
If i = 0 Then 'nix gefunden
MsgBox "Keine Datei gefunden!", vbExclamation
Exit Sub
End If
On Error GoTo ErrorHandler:
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With
For i = LBound(ArFiles) To UBound(ArFiles)
With Workbooks.Open(ArFiles(i), False, False)
sTabName = Left$(.Name, InStrRev(.Name, ".") - 1)
If IsNumeric(sTabName) Then sTabName = CInt(sTabName)
sTabName = "Tabelle" & sTabName
For j = 1 To .Worksheets.Count
If .Worksheets(j).Name = sTabName Then
With .Worksheets(j)
Set rngData = .UsedRange
End With
End If
If Not rngData Is Nothing Then
If oWS Is Nothing Then
With ThisWorkbook
Set oWS = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
End With
End If
With oWS
Set rngZiel = .Cells(.Rows.Count, 1).End(xlUp)
If rngZiel.Row > 1 Or rngZiel.Value  "" Then
Set rngZiel = rngZiel.Offset(1)
End If
rngData.Copy rngZiel
rngZiel.Value = rngZiel.Value 'evtl. Formel durch Werte esetzen
End With
Set rngData = Nothing
Set rngZiel = Nothing
'Tabelle neu erstellen
.Worksheets(j).Delete
.Sheets("Tabelle1").Copy After:=.Sheets(.Sheets.Count)
.ActiveSheet.Name = sTabName
booSave = True
Exit For
End If
Next
.Close booSave
booSave = False
Set rngData = Nothing
End With
Next
ErrorHandler:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
End With
If Err.Number  0 Then
MsgBox Err.Description, vbCritical, "Fehler"
Else
MsgBox "Aufgabe durchgeführt!" & vbCr & _
"Es wurden " & UBound(ArFiles) + 1 & " Dateien bearbeitet und" & vbCr & _
"nach " & oWS.Name & " kopiert!", vbInformation
End If
End Sub

Gruß Tino

Beliebteste Forumthreads (12 Monate)

Auslesen einer Datei und schreiben in Neue

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread