Supportnet / Forum / Tabellenkalkulation
excel dateien in excel importieren
Frage
Ich habe jeweils 22 xls dateien, von denen einige Werte in einer Excel- Datei zusammengefasst werden sollen. Da ich dieses Spiel für 660 Datensätze durchführen muss, benötige ich Hilfe bei der Erstellung eines Skriptes oder einer Vorlagendatei, die automatisch nach Eingabe des Dateiordners die 22 Dateien zusammenfasst. Ist das möglich?
Antwort 1 von coros
Moin unihauke,
gestatte mir zum Anfang eine kleine Anmerkung. Mit einem Hallo am Anfang und ein Gruß am Ende würde Deinen Beitrag gleich viel netter aussehen lassen. Denn die Leute, an die Du Deine Frage richtest, sitzen zwar am PC, sind aber dennoch Menschen.
Nun zu Deiner Frage: Ja, das ist möglich. Allerdings benötigt man zum Erstellen eines Makros schon noch ein paar Angaben. Eine wichtige Angabe ist, ob die Dateien alle in einem Verzeichnis stehen (wäre für ein Makro besser) oder wild auf der Platte verteilt sind. Dann, ob die Daten immer in den gleichen Zellen stehen. Wenn ja, wo? Schreib einfach so viele Infos wie möglich.
So, dann gib mal bescheid, wie Du Dir das vorgestellt hast, dann basteln wir hier etwas zusammen. ;-)
MfG,
coros
Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du ein
Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.
gestatte mir zum Anfang eine kleine Anmerkung. Mit einem Hallo am Anfang und ein Gruß am Ende würde Deinen Beitrag gleich viel netter aussehen lassen. Denn die Leute, an die Du Deine Frage richtest, sitzen zwar am PC, sind aber dennoch Menschen.
Nun zu Deiner Frage: Ja, das ist möglich. Allerdings benötigt man zum Erstellen eines Makros schon noch ein paar Angaben. Eine wichtige Angabe ist, ob die Dateien alle in einem Verzeichnis stehen (wäre für ein Makro besser) oder wild auf der Platte verteilt sind. Dann, ob die Daten immer in den gleichen Zellen stehen. Wenn ja, wo? Schreib einfach so viele Infos wie möglich.
So, dann gib mal bescheid, wie Du Dir das vorgestellt hast, dann basteln wir hier etwas zusammen. ;-)
MfG,
coros
Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du ein
Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.
Antwort 2 von unihauke
Guten Morgen. :)
Ja, die Dateien sind jeweils in einem Ordner. Es sollen immer die Angaben aus einem zweiten Tabellenblatt von Spalte B2 bis E2 übertragen werden.
Meist für 20 Zeilen, also bis B22 und E22. Zusätzlich muss aus den Tabellen zweimal die Spalte A übertragen werden, da es jeweils 11 Fragen für Jungen gibt und 11 für Mädchen und diese sollen untereinander zusammengefasst werden. (Leere Zeilen dazwischen kann man ja einfach ausblenden.)
Viele Grüße, hauke.
Ja, die Dateien sind jeweils in einem Ordner. Es sollen immer die Angaben aus einem zweiten Tabellenblatt von Spalte B2 bis E2 übertragen werden.
Meist für 20 Zeilen, also bis B22 und E22. Zusätzlich muss aus den Tabellen zweimal die Spalte A übertragen werden, da es jeweils 11 Fragen für Jungen gibt und 11 für Mädchen und diese sollen untereinander zusammengefasst werden. (Leere Zeilen dazwischen kann man ja einfach ausblenden.)
Viele Grüße, hauke.
Antwort 3 von coros
Hi Hauke,
es wäre schön, wenn Du Dich noch ein wenig über die Dateinamen ausgelassen hättest. Wie lauten diese? Haben die alle ähnliche Namen und unterscheiden sich nur durch z.B. eine Nummer oder haben die Dateinamen keine Ähnlichkeiten?
Was verstehst Du unter:
Muss aus jeder Tabelle die Spalte A 2x übertragen werden oder nur aus einigen?
Außerdem wäre es sinnvoll, wenn Du schreiben würdest, wohin die Daten eigentlich kopiert werden sollen. Pro ausgelesene Datei ein Tabellenblatt oder wie, bzw. wo sollen sonst die Dateien hin?
MfG,
coros
Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du ein
Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.
es wäre schön, wenn Du Dich noch ein wenig über die Dateinamen ausgelassen hättest. Wie lauten diese? Haben die alle ähnliche Namen und unterscheiden sich nur durch z.B. eine Nummer oder haben die Dateinamen keine Ähnlichkeiten?
Was verstehst Du unter:
Zitat:
Zusätzlich muss aus den Tabellen zweimal die Spalte A übertragen werden
Zusätzlich muss aus den Tabellen zweimal die Spalte A übertragen werden
Muss aus jeder Tabelle die Spalte A 2x übertragen werden oder nur aus einigen?
Außerdem wäre es sinnvoll, wenn Du schreiben würdest, wohin die Daten eigentlich kopiert werden sollen. Pro ausgelesene Datei ein Tabellenblatt oder wie, bzw. wo sollen sonst die Dateien hin?
MfG,
coros
Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du ein
Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.
Antwort 4 von nighty
hi all :))
hier ein beispiel :)
gruss nighty
rem makro01 ist zu starten
Private Type BrowseInfo
hwndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pIDList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Sub makro01()
Application.DisplayAlerts = False
Dim i, zaehler1, a, b, alta, altb, lzeile, lspalte
Dim lastcell As Range
With Application.FileSearch
.NewSearch
.LookIn = Ordnerwählen("Ab welchem Verzeichnis einlesen?")
.SearchSubFolders = False
.Filename = "*.*"
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
Workbooks.Open Filename:=.FoundFiles(i)
rem mappe sheet wie bereichsangaben
Workbooks(2).Sheets(1).Range("A1:A6").Copy
letzte = Workbooks(1).Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
Workbooks(1).Sheets(1).Cells(letzte, 1).Insert Shift:=xlDown
Workbooks(2).Sheets(1).Application.CutCopyMode = False
Workbooks(2).Close
Next i
End If
End With
Application.DisplayAlerts = True
End Sub
Private Function Ordnerwählen(ByVal strTitle As String) As String
Dim lngIDList As Long
Dim strBuffer As String
Dim UserBrowseInfo As BrowseInfo
With UserBrowseInfo
.hwndOwner = 0
.lpszTitle = lstrcat(strTitle, "")
.ulFlags = 3
End With
lngIDList = SHBrowseForFolder(UserBrowseInfo)
If (lngIDList) Then
strBuffer = Space(260)
SHGetPathFromIDList lngIDList, strBuffer
strBuffer = Left(strBuffer, InStr(strBuffer, vbNullChar) - 1)
Ordnerwählen = strBuffer
End If
End Function
hier ein beispiel :)
gruss nighty
rem makro01 ist zu starten
Private Type BrowseInfo
hwndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pIDList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Sub makro01()
Application.DisplayAlerts = False
Dim i, zaehler1, a, b, alta, altb, lzeile, lspalte
Dim lastcell As Range
With Application.FileSearch
.NewSearch
.LookIn = Ordnerwählen("Ab welchem Verzeichnis einlesen?")
.SearchSubFolders = False
.Filename = "*.*"
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
Workbooks.Open Filename:=.FoundFiles(i)
rem mappe sheet wie bereichsangaben
Workbooks(2).Sheets(1).Range("A1:A6").Copy
letzte = Workbooks(1).Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
Workbooks(1).Sheets(1).Cells(letzte, 1).Insert Shift:=xlDown
Workbooks(2).Sheets(1).Application.CutCopyMode = False
Workbooks(2).Close
Next i
End If
End With
Application.DisplayAlerts = True
End Sub
Private Function Ordnerwählen(ByVal strTitle As String) As String
Dim lngIDList As Long
Dim strBuffer As String
Dim UserBrowseInfo As BrowseInfo
With UserBrowseInfo
.hwndOwner = 0
.lpszTitle = lstrcat(strTitle, "")
.ulFlags = 3
End With
lngIDList = SHBrowseForFolder(UserBrowseInfo)
If (lngIDList) Then
strBuffer = Space(260)
SHGetPathFromIDList lngIDList, strBuffer
strBuffer = Left(strBuffer, InStr(strBuffer, vbNullChar) - 1)
Ordnerwählen = strBuffer
End If
End Function
Antwort 5 von unihauke
Schon mal vielen Dank für eure Mühe. Werde das bisher dargestellte dann gleich mal probieren.
Zu den Dateinamen: Die unterscheiden sich nur gerinfügig durch maximal 3 Zahlen und 11 Fragen tragen im namen ein m statt ein w (was aber in der Tabelle berücksichtigt wird.
Die Zusammenführung soll also folgendermaßen geschehen:
Voraussetzung: 11 Tabellen (m- f1-f11), 11 Tabellen Mädchen (w- f1-f11).
Eine Tabelle in der zusammengefasst werden soll.
Erste zeile: fest (Name, F1-0,F1-1,F1-2...)
Zweite bis 21. Zeile (Spalte A: Namen der Jungs (wird aus der ersten Frage ausgelesen (also m-f1) und danach die Ergebnisse aus den einzelnen Fragebögen (wie vorhin beschrieben). 22.-32. Spalte. Das gleiche für die weiblichen Teilnehmer. Also aus (w-f1 die Namen holen) und die Ergebnisse der Fragen zusammensuchen.
@nighty: sobald ich das Makro probiert habe, schreibe ich ob es klappt.
Zu den Dateinamen: Die unterscheiden sich nur gerinfügig durch maximal 3 Zahlen und 11 Fragen tragen im namen ein m statt ein w (was aber in der Tabelle berücksichtigt wird.
Die Zusammenführung soll also folgendermaßen geschehen:
Voraussetzung: 11 Tabellen (m- f1-f11), 11 Tabellen Mädchen (w- f1-f11).
Eine Tabelle in der zusammengefasst werden soll.
Erste zeile: fest (Name, F1-0,F1-1,F1-2...)
Zweite bis 21. Zeile (Spalte A: Namen der Jungs (wird aus der ersten Frage ausgelesen (also m-f1) und danach die Ergebnisse aus den einzelnen Fragebögen (wie vorhin beschrieben). 22.-32. Spalte. Das gleiche für die weiblichen Teilnehmer. Also aus (w-f1 die Namen holen) und die Ergebnisse der Fragen zusammensuchen.
@nighty: sobald ich das Makro probiert habe, schreibe ich ob es klappt.
Antwort 6 von unihauke
Hi, kleine Anmerkung noch vor der Mittagspause...
noch etwas zu den dateinamen:
der Dateiname in einer der Zusammenfassungsdateien lautet:
"C:\Windows\Desktop\Psycho neu\Messzeitpunkt 2\2-09\[ms-09-2-m-f1.xls]Tabelle2!´A2"
Das ist also im Moment der erste Name, der für einen Jungen eingelesen wird. Für alle anderen Datensätze ändert sich der eventuell der Messzeitpunkt (von 2-4) und die Nummer (09). Der Rest bleibt immer gleich (außer bei den Mädchen, wo noch statt m ein w steht.
Danke, hauke.
noch etwas zu den dateinamen:
der Dateiname in einer der Zusammenfassungsdateien lautet:
"C:\Windows\Desktop\Psycho neu\Messzeitpunkt 2\2-09\[ms-09-2-m-f1.xls]Tabelle2!´A2"
Das ist also im Moment der erste Name, der für einen Jungen eingelesen wird. Für alle anderen Datensätze ändert sich der eventuell der Messzeitpunkt (von 2-4) und die Nummer (09). Der Rest bleibt immer gleich (außer bei den Mädchen, wo noch statt m ein w steht.
Danke, hauke.
Antwort 7 von nighty
hi hauke
hier vielleicht besser anpassbar
gruss nighty
Option Explicit
Private Type BrowseInfo
hwndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pIDList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Sub makro01()
Dim i As Integer, letzte As Integer
Application.DisplayAlerts = False
With Application.FileSearch
.NewSearch
.LookIn = Ordnerwählen("Ab welchem Verzeichnis einlesen?")
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
Workbooks.Open Filename:=.FoundFiles(i)
Rem hier deine bereichsangaben leicht anpassbar sind
Workbooks(2).Sheets(1).Range("A1:A22", "B1:F22").Copy
letzte = Workbooks(1).Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
Workbooks(1).Sheets(1).Cells(letzte, 1).Insert Shift:=xlDown
Workbooks(2).Sheets(1).Application.CutCopyMode = False
Workbooks(2).Close
Next i
End If
End With
Application.DisplayAlerts = True
End Sub
Private Function Ordnerwählen(ByVal strTitle As String) As String
Dim lngIDList As Long
Dim strBuffer As String
Dim UserBrowseInfo As BrowseInfo
With UserBrowseInfo
.hwndOwner = 0
.lpszTitle = lstrcat(strTitle, "")
.ulFlags = 3
End With
lngIDList = SHBrowseForFolder(UserBrowseInfo)
If (lngIDList) Then
strBuffer = Space(260)
SHGetPathFromIDList lngIDList, strBuffer
strBuffer = Left(strBuffer, InStr(strBuffer, vbNullChar) - 1)
Ordnerwählen = strBuffer
End If
End Function
hier vielleicht besser anpassbar
gruss nighty
Option Explicit
Private Type BrowseInfo
hwndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pIDList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Sub makro01()
Dim i As Integer, letzte As Integer
Application.DisplayAlerts = False
With Application.FileSearch
.NewSearch
.LookIn = Ordnerwählen("Ab welchem Verzeichnis einlesen?")
.SearchSubFolders = False
.Filename = "*.xls"
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
Workbooks.Open Filename:=.FoundFiles(i)
Rem hier deine bereichsangaben leicht anpassbar sind
Workbooks(2).Sheets(1).Range("A1:A22", "B1:F22").Copy
letzte = Workbooks(1).Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
Workbooks(1).Sheets(1).Cells(letzte, 1).Insert Shift:=xlDown
Workbooks(2).Sheets(1).Application.CutCopyMode = False
Workbooks(2).Close
Next i
End If
End With
Application.DisplayAlerts = True
End Sub
Private Function Ordnerwählen(ByVal strTitle As String) As String
Dim lngIDList As Long
Dim strBuffer As String
Dim UserBrowseInfo As BrowseInfo
With UserBrowseInfo
.hwndOwner = 0
.lpszTitle = lstrcat(strTitle, "")
.ulFlags = 3
End With
lngIDList = SHBrowseForFolder(UserBrowseInfo)
If (lngIDList) Then
strBuffer = Space(260)
SHGetPathFromIDList lngIDList, strBuffer
strBuffer = Left(strBuffer, InStr(strBuffer, vbNullChar) - 1)
Ordnerwählen = strBuffer
End If
End Function
Antwort 8 von coros
Hallo hauke,
irgendwie schreibst Du immer nur einen Teil von dem, was eigentlich benötigt wird. Aus dem was Du da schreibst, werde ich immer noch nicht so ganz schlau. Mir fehlen immer noch die Angaben, wo die Daten im einzelnen hin kopiert werden sollen. Wobei ich ehrlich gesagt auch noch nicht ganz verstehe, welche Daten nun kopiert werden sollen, da ich mir noch nicht im Klaren bin, wie Deine Dateien, die ausgelesen werden sollen, vom Aufbau her aussehen. Besteht die Möglichkeit mir sowohl eine Datei für die Mädchen als auch eine Datei für die Jungs und eine Datei, in die die Daten kopiert werden sollen, per Mail zu schicken? Du kannst auch alle persönlichen Daten löschen. Allerdings müssten, sofern Du die Namen löschen musst dort dann Dummynamen, damit ich mir ein Bild machen kann. Also wenn Du willst, schicke die Datei an meine E-Mail:coros@excelbeispiele.de. Ich schau mir das dann mal an und versuche Dir da was zu erstellen.
MfG,
coros
Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du ein
Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.
irgendwie schreibst Du immer nur einen Teil von dem, was eigentlich benötigt wird. Aus dem was Du da schreibst, werde ich immer noch nicht so ganz schlau. Mir fehlen immer noch die Angaben, wo die Daten im einzelnen hin kopiert werden sollen. Wobei ich ehrlich gesagt auch noch nicht ganz verstehe, welche Daten nun kopiert werden sollen, da ich mir noch nicht im Klaren bin, wie Deine Dateien, die ausgelesen werden sollen, vom Aufbau her aussehen. Besteht die Möglichkeit mir sowohl eine Datei für die Mädchen als auch eine Datei für die Jungs und eine Datei, in die die Daten kopiert werden sollen, per Mail zu schicken? Du kannst auch alle persönlichen Daten löschen. Allerdings müssten, sofern Du die Namen löschen musst dort dann Dummynamen, damit ich mir ein Bild machen kann. Also wenn Du willst, schicke die Datei an meine E-Mail:coros@excelbeispiele.de. Ich schau mir das dann mal an und versuche Dir da was zu erstellen.
MfG,
coros
Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du ein
Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.
Antwort 9 von unihauke
Hallo.
Habe jetzt mal das Makro probiert. Nach Abänderung in sheet(2) und A-E importiert er alles.
Kann ich formatieren, in welche Zeilen und Spalten er jeweils kopiert?
------- F1 F2 F3 F4 ...F11
Name 0123 0123 0123 0123...0123
Jungen XXXX XXXX XXXX XXXX XXXX
...
Mädchen xxxx xxxx xxxx xxxx xxxx
...
Das heißt, man müsste jede Frage daneben machen und für die Mädchen untendrunter wieder anfangen.
Ich weiß noch nicht so ganz, wie das alles geht. Vielen Dank für eure Hilfe, hauke.
Habe jetzt mal das Makro probiert. Nach Abänderung in sheet(2) und A-E importiert er alles.
Kann ich formatieren, in welche Zeilen und Spalten er jeweils kopiert?
------- F1 F2 F3 F4 ...F11
Name 0123 0123 0123 0123...0123
Jungen XXXX XXXX XXXX XXXX XXXX
...
Mädchen xxxx xxxx xxxx xxxx xxxx
...
Das heißt, man müsste jede Frage daneben machen und für die Mädchen untendrunter wieder anfangen.
Ich weiß noch nicht so ganz, wie das alles geht. Vielen Dank für eure Hilfe, hauke.
Antwort 10 von unihauke
Private Sub CommandButton1_Click()
Dim Dateiname As String, Spalte_m As Integer, Spalte_w As Integer, _
letzte_Zeile_m As Long, letzte_Zeile_w As Long, Aktive_Datei As String
Aktive_Datei = ActiveWorkbook.Name
Application.ScreenUpdating = False
Range("A2:AS27").ClearContents
Spalte_m = 2
Spalte_w = 2
´Dateiname = Dir("E:\Test\Test\*.xls")
Dateiname = Dir("C:\Windows\Desktop\Psycho neu\ms 2 fehler\2-30\*.xls")
Do While Dateiname <> ""
If Dateiname <> Aktive_Datei Then
´Workbooks.Open "E:\Test\Test\" + Dateiname
Workbooks.Open "C:\Windows\Desktop\Psycho neu\ms 2 fehler\2-30\" + Dateiname
´********************* Auswertung Jungen ********************************
If Mid(Dateiname, 9, 1) = "m" Then
letzte_Zeile_m = Workbooks(Dateiname).Sheets(2).Range("A65536").End(xlUp).Row
Workbooks(Dateiname).Sheets(2).Range("A2:A" & letzte_Zeile_m).Copy
Workbooks(Aktive_Datei).Sheets(1).Cells(2, 1). _
PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Workbooks(Dateiname).Sheets(2).Range("B2:E" & letzte_Zeile_m).Copy
Workbooks(Aktive_Datei).Sheets(1).Cells(2, Spalte_m). _
PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Spalte_m = Spalte_m + 4
End If
´********************* Auswertung Mädchen ********************************
If Mid(Dateiname, 9, 1) = "w" Then
letzte_Zeile_w = Workbooks(Dateiname).Sheets(2).Range("A65536").End(xlUp).Row
Workbooks(Dateiname).Sheets(2).Range("A2:A" & letzte_Zeile_w).Copy
Workbooks(Aktive_Datei).Sheets(1).Cells(10, 1). _
PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Workbooks(Dateiname).Sheets(2).Range("B2:E" & letzte_Zeile_w).Copy
Workbooks(Aktive_Datei).Sheets(1).Cells(10, Spalte_w). _
PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Spalte_w = Spalte_w + 4
End If
Workbooks(Dateiname).Close
End If
Dateiname = Dir
Loop
End Sub
Private Sub CommandButton1_Click()
Dim Dateiname As String, Spalte_m As Integer, Spalte_w As Integer, _
letzte_Zeile_m As Long, letzte_Zeile_w As Long, Aktive_Datei As String
Aktive_Datei = ActiveWorkbook.Name
Application.ScreenUpdating = False
Range("A2:AS27").ClearContents
Spalte_m = 2
Spalte_w = 2
´Dateiname = Dir("E:\Test\Test\*.xls")
Dateiname = Dir("C:\Windows\Desktop\Psycho neu\ms 2 fehler\2-30\*.xls")
Do While Dateiname <> ""
If Dateiname <> Aktive_Datei Then
´Workbooks.Open "E:\Test\Test\" + Dateiname
Workbooks.Open "C:\Windows\Desktop\Psycho neu\ms 2 fehler\2-30\" + Dateiname
´********************* Auswertung Jungen ********************************
If Mid(Dateiname, 9, 1) = "m" Then
letzte_Zeile_m = Workbooks(Dateiname).Sheets(2).Range("A65536").End(xlUp).Row
Workbooks(Dateiname).Sheets(2).Range("A2:A" & letzte_Zeile_m).Copy
Workbooks(Aktive_Datei).Sheets(1).Cells(2, 1). _
PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Workbooks(Dateiname).Sheets(2).Range("B2:E" & letzte_Zeile_m).Copy
Workbooks(Aktive_Datei).Sheets(1).Cells(2, Spalte_m). _
PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Spalte_m = Spalte_m + 4
End If
´********************* Auswertung Mädchen ********************************
If Mid(Dateiname, 9, 1) = "w" Then
letzte_Zeile_w = Workbooks(Dateiname).Sheets(2).Range("A65536").End(xlUp).Row
Workbooks(Dateiname).Sheets(2).Range("A2:A" & letzte_Zeile_w).Copy
Workbooks(Aktive_Datei).Sheets(1).Cells(10, 1). _
PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Workbooks(Dateiname).Sheets(2).Range("B2:E" & letzte_Zeile_w).Copy
Workbooks(Aktive_Datei).Sheets(1).Cells(10, Spalte_w). _
PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Spalte_w = Spalte_w + 4
End If
Workbooks(Dateiname).Close
End If
Dateiname = Dir
Loop
End Sub
Das ist das Skript, was ich im Moment laufen habe. Danke nochmal an COROS. Eine Frage noch. Ich habe jetzt eine Datei mit 26 Jungen, so dass das Einfügen der Mädchen erst ab Zeile 28 laufen soll. Was muss ich denn da ändern, dass er weiß, in welcher Zeile er mit den Mädchen anfängt, aber vorher alle Jungendaten ausliest? danke schon mal im voraus, hauke.
Dim Dateiname As String, Spalte_m As Integer, Spalte_w As Integer, _
letzte_Zeile_m As Long, letzte_Zeile_w As Long, Aktive_Datei As String
Aktive_Datei = ActiveWorkbook.Name
Application.ScreenUpdating = False
Range("A2:AS27").ClearContents
Spalte_m = 2
Spalte_w = 2
´Dateiname = Dir("E:\Test\Test\*.xls")
Dateiname = Dir("C:\Windows\Desktop\Psycho neu\ms 2 fehler\2-30\*.xls")
Do While Dateiname <> ""
If Dateiname <> Aktive_Datei Then
´Workbooks.Open "E:\Test\Test\" + Dateiname
Workbooks.Open "C:\Windows\Desktop\Psycho neu\ms 2 fehler\2-30\" + Dateiname
´********************* Auswertung Jungen ********************************
If Mid(Dateiname, 9, 1) = "m" Then
letzte_Zeile_m = Workbooks(Dateiname).Sheets(2).Range("A65536").End(xlUp).Row
Workbooks(Dateiname).Sheets(2).Range("A2:A" & letzte_Zeile_m).Copy
Workbooks(Aktive_Datei).Sheets(1).Cells(2, 1). _
PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Workbooks(Dateiname).Sheets(2).Range("B2:E" & letzte_Zeile_m).Copy
Workbooks(Aktive_Datei).Sheets(1).Cells(2, Spalte_m). _
PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Spalte_m = Spalte_m + 4
End If
´********************* Auswertung Mädchen ********************************
If Mid(Dateiname, 9, 1) = "w" Then
letzte_Zeile_w = Workbooks(Dateiname).Sheets(2).Range("A65536").End(xlUp).Row
Workbooks(Dateiname).Sheets(2).Range("A2:A" & letzte_Zeile_w).Copy
Workbooks(Aktive_Datei).Sheets(1).Cells(10, 1). _
PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Workbooks(Dateiname).Sheets(2).Range("B2:E" & letzte_Zeile_w).Copy
Workbooks(Aktive_Datei).Sheets(1).Cells(10, Spalte_w). _
PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Spalte_w = Spalte_w + 4
End If
Workbooks(Dateiname).Close
End If
Dateiname = Dir
Loop
End Sub
Private Sub CommandButton1_Click()
Dim Dateiname As String, Spalte_m As Integer, Spalte_w As Integer, _
letzte_Zeile_m As Long, letzte_Zeile_w As Long, Aktive_Datei As String
Aktive_Datei = ActiveWorkbook.Name
Application.ScreenUpdating = False
Range("A2:AS27").ClearContents
Spalte_m = 2
Spalte_w = 2
´Dateiname = Dir("E:\Test\Test\*.xls")
Dateiname = Dir("C:\Windows\Desktop\Psycho neu\ms 2 fehler\2-30\*.xls")
Do While Dateiname <> ""
If Dateiname <> Aktive_Datei Then
´Workbooks.Open "E:\Test\Test\" + Dateiname
Workbooks.Open "C:\Windows\Desktop\Psycho neu\ms 2 fehler\2-30\" + Dateiname
´********************* Auswertung Jungen ********************************
If Mid(Dateiname, 9, 1) = "m" Then
letzte_Zeile_m = Workbooks(Dateiname).Sheets(2).Range("A65536").End(xlUp).Row
Workbooks(Dateiname).Sheets(2).Range("A2:A" & letzte_Zeile_m).Copy
Workbooks(Aktive_Datei).Sheets(1).Cells(2, 1). _
PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Workbooks(Dateiname).Sheets(2).Range("B2:E" & letzte_Zeile_m).Copy
Workbooks(Aktive_Datei).Sheets(1).Cells(2, Spalte_m). _
PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Spalte_m = Spalte_m + 4
End If
´********************* Auswertung Mädchen ********************************
If Mid(Dateiname, 9, 1) = "w" Then
letzte_Zeile_w = Workbooks(Dateiname).Sheets(2).Range("A65536").End(xlUp).Row
Workbooks(Dateiname).Sheets(2).Range("A2:A" & letzte_Zeile_w).Copy
Workbooks(Aktive_Datei).Sheets(1).Cells(10, 1). _
PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Workbooks(Dateiname).Sheets(2).Range("B2:E" & letzte_Zeile_w).Copy
Workbooks(Aktive_Datei).Sheets(1).Cells(10, Spalte_w). _
PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Spalte_w = Spalte_w + 4
End If
Workbooks(Dateiname).Close
End If
Dateiname = Dir
Loop
End Sub
Das ist das Skript, was ich im Moment laufen habe. Danke nochmal an COROS. Eine Frage noch. Ich habe jetzt eine Datei mit 26 Jungen, so dass das Einfügen der Mädchen erst ab Zeile 28 laufen soll. Was muss ich denn da ändern, dass er weiß, in welcher Zeile er mit den Mädchen anfängt, aber vorher alle Jungendaten ausliest? danke schon mal im voraus, hauke.
Antwort 11 von coros
Moin,
nachfolgender Code sollte funktionieren. Ich habe die beiden Zahlen, die geändert werden mussten mal fett gemacht und unterstrichen.
MfG,
coros
Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du ein
Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.
nachfolgender Code sollte funktionieren. Ich habe die beiden Zahlen, die geändert werden mussten mal fett gemacht und unterstrichen.
Private Sub CommandButton1_Click()
Dim Dateiname As String, Spalte_m As Integer, Spalte_w As Integer, _
letzte_Zeile_m As Long, letzte_Zeile_w As Long, Aktive_Datei As String
Aktive_Datei = ActiveWorkbook.Name
Application.ScreenUpdating = False
Range("A2:AS27").ClearContents
Spalte_m = 2
Spalte_w = 2
Dateiname = Dir("C:\Windows\Desktop\Psycho neu\ms 2 fehler\2-30\*.xls")
Do While Dateiname <> ""
If Dateiname <> Aktive_Datei Then
Workbooks.Open "C:\Windows\Desktop\Psycho neu\ms 2 fehler\2-30\" + Dateiname
Rem********************* Auswertung Jungen ********************************
If Mid(Dateiname, 9, 1) = "m" Then
letzte_Zeile_m = Workbooks(Dateiname).Sheets(2).Range("A65536").End(xlUp).Row
Workbooks(Dateiname).Sheets(2).Range("A2:A" & letzte_Zeile_m).Copy
Workbooks(Aktive_Datei).Sheets(1).Cells(2, 1). _
PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Workbooks(Dateiname).Sheets(2).Range("B2:E" & letzte_Zeile_m).Copy
Workbooks(Aktive_Datei).Sheets(1).Cells(2, Spalte_m). _
PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Spalte_m = Spalte_m + 4
End If
Rem********************* Auswertung Mädchen ********************************
If Mid(Dateiname, 9, 1) = "w" Then
letzte_Zeile_w = Workbooks(Dateiname).Sheets(2).Range("A65536").End(xlUp).Row
Workbooks(Dateiname).Sheets(2).Range("A2:A" & letzte_Zeile_w).Copy
Workbooks(Aktive_Datei).Sheets(1).Cells(28, 1). _
PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Workbooks(Dateiname).Sheets(2).Range("B2:E" & letzte_Zeile_w).Copy
Workbooks(Aktive_Datei).Sheets(1).Cells(28, Spalte_w). _
PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Spalte_w = Spalte_w + 4
End If
Workbooks(Dateiname).Close
End If
Dateiname = Dir
Loop
End SubMfG,
coros
Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du ein
Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.
Antwort 12 von unihauke
Guten Morgen,
die Änderung hatte ich schon gemacht, und auch versucht, bei Range die Größe zu ändern.
Allerdings passiert es nun, dass er die Jungen bis A15 einfügt und dann wieder ab A28, von den Mädchen ist aber nix zu sehen. Woran kann das liegen? Danke, hauke.
die Änderung hatte ich schon gemacht, und auch versucht, bei Range die Größe zu ändern.
Allerdings passiert es nun, dass er die Jungen bis A15 einfügt und dann wieder ab A28, von den Mädchen ist aber nix zu sehen. Woran kann das liegen? Danke, hauke.