Hey, :-)
habe mit super Unterstützung von hier aus dem Forum den folgenden Code erstellt, der wunderbar funktioniert. ;-)
Zweck dabei ist es, die Inhalte verschiedener, identisch aufgebauter Tabellen im gleichen Ordner auszulesen und eine andere Datei zu übernehmen.
Nun brauche ich für eine andere Datei genau die gleiche Funktion, jedoch stehen die Daten dort nicht wie hier jeweils auf Blatt 1 der Ausgangstabellen, sondern auf Blatt 2... :-(
Kann mir jemand sagen, was ich dazu im Code ändern muss (alles andere bleibt gleich) - ich finde einfach keine Stelle im Code, die sich darauf bezieht...
VG u. vielen Dank Euch für jeden Tipp,
Mike
Sheets(1).Select
Range("R9:S39").Select
Selection.ClearContents
Range("A2:A3").Select
Sheets(3).Visible = True
Sheets(3).Select
Range("A9:S39").Select
Selection.ClearContents
Range("A2:A3").Select
Sheets(4).Visible = True
Sheets(4).Select
Range("A9:S39").Select
Selection.ClearContents
Range("A2:A3").Select
Sheets(5).Visible = True
Sheets(5).Select
Range("A9:S39").Select
Selection.ClearContents
Range("A2:A3").Select
Sheets(6).Visible = True
Sheets(6).Select
Range("A9:S39").Select
Selection.ClearContents
Range("A2:A3").Select
Sheets(7).Visible = True
Sheets(7).Select
Range("A9:S39").Select
Selection.ClearContents
Range("A2:A3").Select
Sheets(8).Visible = True
Sheets(8).Select
Range("A9:S39").Select
Selection.ClearContents
Range("A2:A3").Select
Sheets(9).Visible = True
Sheets(9).Select
Range("A9:S39").Select
Selection.ClearContents
Range("A2:A3").Select
Sheets(10).Visible = True
Sheets(10).Select
Range("A9:S39").Select
Selection.ClearContents
Range("A2:A3").Select
Sheets(1).Select
Range("A2:A3").Select
Dim I As Integer, J As Integer
Dim Datei As String, Pfad As String
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Pfad = ThisWorkbook.Path
Datei = Dir(Pfad & "\*.xls")
I = 9
Do While Datei ""
If Datei = ThisWorkbook.Name Then GoTo Weiter
Workbooks.Open Pfad & "\" & Datei
'##################### Daten kopieren #################
With ThisWorkbook.Sheets(3)
.Cells(I, 1).Value = Datei
For J = 1 To 18
.Cells(I, J + 1).Value = ActiveWorkbook.Sheets(1).Application.WorksheetFunction.Sum(Range(Cells(9, J + 1), Cells(10, J + 1)).Value)
Next J
End With
With ThisWorkbook.Sheets(4)
.Cells(I, 1).Value = Datei
For J = 1 To 18
.Cells(I, J + 1).Value = ActiveWorkbook.Sheets(1).Application.WorksheetFunction.Sum(Range(Cells(13, J + 1), Cells(15, J + 1)).Value)
Next J
End With
With ThisWorkbook.Sheets(5)
.Cells(I, 1).Value = Datei
For J = 1 To 18
.Cells(I, J + 1).Value = ActiveWorkbook.Sheets(1).Application.WorksheetFunction.Sum(Range(Cells(18, J + 1), Cells(21, J + 1)).Value)
Next J
End With
With ThisWorkbook.Sheets(6)
.Cells(I, 1).Value = Datei
For J = 1 To 18
.Cells(I, J + 1).Value = ActiveWorkbook.Sheets(1).Cells(24, J + 1).Value
Next J
End With
With ThisWorkbook.Sheets(7)
.Cells(I, 1).Value = Datei
For J = 1 To 18
.Cells(I, J + 1).Value = ActiveWorkbook.Sheets(1).Application.WorksheetFunction.Sum(Range(Cells(27, J + 1), Cells(32, J + 1)).Value)
Next J
End With
With ThisWorkbook.Sheets(8)
.Cells(I, 1).Value = Datei
For J = 1 To 18
.Cells(I, J + 1).Value = ActiveWorkbook.Sheets(1).Cells(35, J + 1).Value
Next J
End With
With ThisWorkbook.Sheets(9)
.Cells(I, 1).Value = Datei
For J = 1 To 3
.Cells(I, J + 1).Value = ActiveWorkbook.Sheets(1).Application.WorksheetFunction.Sum(Range(Cells(38, J + 1), Cells(67, J + 1)).Value)
Next J
End With
With ThisWorkbook.Sheets(10)
.Cells(I, 1).Value = Datei
For J = 1 To 3
.Cells(I, J + 1).Value = ActiveWorkbook.Sheets(1).Application.WorksheetFunction.Sum(Range(Cells(70, J + 1), Cells(90, J + 1)).Value)
Next J
End With
'##################### Ende Daten kopieren #################
ActiveWorkbook.Close False
I = I + 1
Weiter:
Datei = Dir()
Loop
Sheets(3).Visible = False
Sheets(4).Visible = False
Sheets(5).Visible = False
Sheets(6).Visible = False
Sheets(7).Visible = False
Sheets(8).Visible = False
Sheets(9).Visible = False
Sheets(10).Visible = False
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub