Moin moin,
ich bräuchte da mal ein wenig Unterstützung.
Habe nämlich von VBA gar keine Ahnung und habe von einem Kollegen (der sich auch nicht besonders auskennt) eine Datei samt Makro bekommen, die wie er sagt einfach & zusammen kopiert wurde.
Mein Vorhaben ist, aus gleich aufgebauten Dateien (welche sich in verschiedenen Unterverzeichnissen befinden) Informationen auszulesen und diese in eine Datei als Übersicht zu packen.
Das Makro funktioniert auch soweit, allerdings liest es immer nur das ausgewählte Verzeichnis aus OHNE Unterverzeichnisse.
Könnt ihr mir da vielleicht weiterhelfen?
Vielen Dank schonmal.
Liebe Grüße
Roman
CodeTags korrigiert ~VaporiZed
ich bräuchte da mal ein wenig Unterstützung.
Habe nämlich von VBA gar keine Ahnung und habe von einem Kollegen (der sich auch nicht besonders auskennt) eine Datei samt Makro bekommen, die wie er sagt einfach & zusammen kopiert wurde.
Mein Vorhaben ist, aus gleich aufgebauten Dateien (welche sich in verschiedenen Unterverzeichnissen befinden) Informationen auszulesen und diese in eine Datei als Übersicht zu packen.
Das Makro funktioniert auch soweit, allerdings liest es immer nur das ausgewählte Verzeichnis aus OHNE Unterverzeichnisse.
Könnt ihr mir da vielleicht weiterhelfen?
Visual Basic-Quellcode
- Sub OrdnerAuswählen(strVerzeichnis As String)
- 'Dim strVerzeichnis As String
- Dim StrDatei As String
- Dim StrTyp As String
- Dim objFileDialog As Office.FileDialog
- 'FolderPicker
- Set objFileDialog = Application.FileDialog(MsoFileDialogType.msoFileDialogFolderPicker)
- With objFileDialog
- .AllowMultiSelect = True
- .ButtonName = "Folder Picker"
- .Title = "Folder Picker"
- If (.Show > 0) Then
- End If
- If (.SelectedItems.Count > 0) Then
- ' Call MsgBox(.SelectedItems(1))
- strVerzeichnis = .SelectedItems(1)
- End If
- End With
- MsgBox (strVerzeichnis)
- End Sub
- Sub KontaktdatenAuslesen()
- Dim strVerzeichnis As String
- Dim Counter As Integer
- Dim Dateiname As String
- Dim wbQuelle As Workbook
- Dim wksQuelle As Worksheet
- Dim wbZiel As Workbook
- Dim wksZiel As Worksheet
- Dim strZiel As String, strPfadZiel As String
- Dim Zeile_Z As Long, Zelle_Letzte As Range
- Set wbZiel = ThisWorkbook
- Set wksZiel = wbZiel.Worksheets("Kontaktdaten")
- Counter = 0
- OrdnerAuswählen strVerzeichnis
- 'Alle Oefnnen
- Dateiname = Dir(strVerzeichnis & "\" & "Personalakte.xlsx")
- 'MsgBox (Dateiname)
- Do While Dateiname <> ""
- Set wbQuelle = Workbooks.Open(strVerzeichnis & "\" & Dateiname)
- Set wksQuelle = wbQuelle.Worksheets("Allgemein")
- With wksZiel
- 'Letze Zelle ermitteln
- Set Zelle_Letzte = .Cells.Find(What:="*", After:=Range("A1"), _
- LookIn:=xlFormulas, lookat:=xlWhole, searchorder:=xlByRows, _
- searchdirection:=xlPrevious)
- If Zelle_Letzte Is Nothing Then
- Zeile_Z = 1
- Else
- Zeile_Z = Zelle_Letzte.Row + 1
- End If
- 'Zellinhalte übertragen - nur Werte
- wksQuelle.Range("B12").Copy
- wksZiel.Cells(Zeile_Z, 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
- wksQuelle.Range("B5").Copy
- wksZiel.Cells(Zeile_Z, 2).PasteSpecial Paste:=xlPasteValues, Transpose:=True
- wksQuelle.Range("B1").Copy
- wksZiel.Cells(Zeile_Z, 3).PasteSpecial Paste:=xlPasteValues, Transpose:=True
- wksQuelle.Range("B2").Copy
- wksZiel.Cells(Zeile_Z, 4).PasteSpecial Paste:=xlPasteValues, Transpose:=True
- wksQuelle.Range("B7").Copy
- wksZiel.Cells(Zeile_Z, 5).PasteSpecial Paste:=xlPasteValues, Transpose:=True
- wksQuelle.Range("B8").Copy
- wksZiel.Cells(Zeile_Z, 6).PasteSpecial Paste:=xlPasteValues, Transpose:=True
- wksQuelle.Range("B17").Copy
- wksZiel.Cells(Zeile_Z, 7).PasteSpecial Paste:=xlPasteValues, Transpose:=True
- wksQuelle.Range("B16").Copy
- wksZiel.Cells(Zeile_Z, 8).PasteSpecial Paste:=xlPasteValues, Transpose:=True
- wksQuelle.Range("B19").Copy
- wksZiel.Cells(Zeile_Z, 9).PasteSpecial Paste:=xlPasteValues, Transpose:=True
- wksQuelle.Range("B20").Copy
- wksZiel.Cells(Zeile_Z, 10).PasteSpecial Paste:=xlPasteValues, Transpose:=True
- wksQuelle.Range("B22").Copy
- wksZiel.Cells(Zeile_Z, 11).PasteSpecial Paste:=xlPasteValues, Transpose:=True
- End With
- wbQuelle.Close savechanges:=False
- Counter = Counter + 1
- Dateiname = Dir
- Loop
- MsgBox (Counter & " Personalakten")
- End Sub
Vielen Dank schonmal.
Liebe Grüße
Roman
CodeTags korrigiert ~VaporiZed
Dieser Beitrag wurde bereits 1 mal editiert, zuletzt von „VaporiZed“ ()