Registriert seit: 17.07.2016
Version(en): 2016
Hallo zusammen,
ich habe ein Makro im Internet gefunden, wo ich aus verschiedenen Exceldateien bestimmte Zellen in eine neue Exceldatei übertrage.
Dies funktioniert echt super - lediglich hätte ich gerne, dass ein Benutzer beim Ausführen des Makros mittels Popup Fenster
den gewünschten Ordner (wo die Dateien liegen) auswählen muss.
Denn momentan ist es so, dass der Pfad zum Ordner manuell im Makro eingetragen werden muss - dies kann ich jedoch nicht von allen Benutzern erwarten bzw. beibringen.
Der momentane Code sieht wie folgt aus:
Code: blic Sub QAFsauswerten()
Dim strDateiname As String
Dim strPfad As String
Dim lngZeile As Long
'Pfadangabe, in dem die zu lesenden Excel-Datei (*.xls) liegen
strPfad = "C:\Users\z563164\Desktop\testquaf"
'Den 1. Dateinamen holen
strDateiname = Dir(strPfad & "*.xls")
'Startzeile festlegen
lngZeile = 2
'Solange ein Dateiname gelesen wird
Do While Not strDateiname = ""
'Datei verarbeiten
Call TabVerarb(strPfad & strDateiname, lngZeile)
'nächsten Dateinamen holen
strDateiname = Dir()
'Zeilenzähler erhöhen
lngZeile = lngZeile + 1
Loop
End Sub
Sprich, die Pfadangabe soll über ein Popup Fenster sich "selber" in das Makro schreiben.
Registriert seit: 14.04.2014
Version(en): Office 2013/2016/2019/365
18.07.2016, 15:48
(Dieser Beitrag wurde zuletzt bearbeitet: 18.07.2016, 15:48 von chris-ka.)
Hi,
füge ein neues Modul ein und diesen Code dort einfügen
Code: ' Benötigte API-Deklarationen
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 Const MAX_PATH = 260
'Private Const BIF_RETURNONLYFSDIRS = &H1
Private Const BIF_RETURNONLYFSDIRS = &H40
Private Const BFFM_SETSELECTION = &H466
Private Const BFFM_INITIALIZED = 1
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal Msg As Long, wParam As Any, lParam As Any) As Long
Private m_BrowseInitDir As String
Public Function BrowseForFolder(ByVal sPrompt As String, Optional ByVal sInitDir As String) As String
Dim nPos As Long
Dim nIDList As Long
Dim sPath As String
Dim oInfo As BrowseInfo
m_BrowseInitDir = sInitDir
With oInfo
.hWndOwner = GetActiveWindow()
.lpszTitle = lstrcat(sPrompt, "")
.ulFlags = BIF_RETURNONLYFSDIRS
If sInitDir <> "" Then
.lpfnCallback = FuncCallback(AddressOf BrowseCallback)
End If
End With
nIDList = SHBrowseForFolder(oInfo)
If nIDList Then
sPath = String$(MAX_PATH, 0)
Call SHGetPathFromIDList(nIDList, sPath)
Call CoTaskMemFree(nIDList)
nPos = InStr(sPath, vbNullChar)
If nPos Then sPath = Left$(sPath, nPos - 1)
End If
BrowseForFolder = sPath
End Function
Private Function BrowseCallback(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case uMsg
Case BFFM_INITIALIZED
Call SendMessage(hWnd, BFFM_SETSELECTION, ByVal 1&, ByVal m_BrowseInitDir)
End Select
BrowseCallback = 0
End Function
Private Function FuncCallback(ByVal nParam As Long) As Long
FuncCallback = nParam
End Function
deinen Code so ändern.
Code: Sub QAFsauswerten()
Dim strDateiname As String
Dim strPfad As String
Dim lngZeile As Long
Dim Caption As String, s_Verzeichnis As String
Caption = "Verzeichnisübersicht"
'Pfadangabe, in dem die zu lesenden Excel-Datei (*.xls) liegen
strPfad = "C:\Users\z563164\Desktop\testquaf"
strPfad = BrowseForFolder(Caption, strPfad)
'Den 1. Dateinamen holen
strDateiname = Dir(strPfad & "*.xls")
'Startzeile festlegen
lngZeile = 2
'Solange ein Dateiname gelesen wird
Do While Not strDateiname = ""
'Datei verarbeiten
Call TabVerarb(strPfad & strDateiname, lngZeile)
'nächsten Dateinamen holen
strDateiname = Dir()
'Zeilenzähler erhöhen
lngZeile = lngZeile + 1
Loop
End Sub
oder den einfachen Dialog
mit Application.FileDialog(msoFileDialogFolderPicker)
verwenden.
der müsste auch reichen
Code: Sub QAFsauswerten()
Dim strDateiname As String
Dim strPfad As String
Dim lngZeile As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "c:\" '"C:\Users\z563164\Desktop\testquaf"
.Title = "Ordner"
.ButtonName = "your Choice :)"
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strPfad = .SelectedItems(1)
If Right(strPfad, 1) <> "\" Then strPfad = strPfad & "\"
Else
strPfad = ""
End If
End With
If strPfad = "" Then
Exit Sub
Else
'Den 1. Dateinamen holen
strDateiname = Dir(strPfad & "*.xls")
'Startzeile festlegen
lngZeile = 2
'Solange ein Dateiname gelesen wird
Do While Not strDateiname = ""
'Datei verarbeiten
Call TabVerarb(strPfad & strDateiname, lngZeile)
'nächsten Dateinamen holen
strDateiname = Dir()
'Zeilenzähler erhöhen
lngZeile = lngZeile + 1
Loop
End If
End Sub
lg Chris
Feedback nicht vergessen.
3a2920576572206973742064656e20646120736f206e65756769657269672e
Registriert seit: 12.03.2016
Version(en): Excel 2003
hallo
Anbei ein kurzes Makro das ich in einem Forum für Dateien auflisten fand. Da gab es auch einen
Codeabschnitt um den Ordner über DialogBox zu suchen. Vielleicht kannst du ihn verwenden?
strFolder müsste in strPfad umbenannt werden! Dann könnte es klappen. Einfach mal testen.
Sub DateiListe()
Dim strFolder As String, wksListe As Worksheet
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Ordner wählen"
.AllowMultiSelect = False
If .Show = -1 Then
strFolder = .SelectedItems(1)
End If
End With
If strFolder = "" Then Exit Sub
Registriert seit: 17.07.2016
Version(en): 2016
Hi Christ,
dein zweiter Vorschlag hat einwandfrei funktioniert! Vielen Dank!
Registriert seit: 17.07.2016
Version(en): 2016
Hallo zusammen,
jetzt hätte ich noch ein Anliegen. Abhängig von einem bestimmen Zellwert, z.Bsp. wenn in B106 der Text "XYZ" steht, soll Makro2 starten.
Wenn in B106 nichts steht, soll Makro1 starten.
Da ich in VBA ehrlich keine Ahnung habe, weiß ich nicht, wie ich das in meinem Code bringen soll. Hintergrund ist, dass die zu durchsuchenden Dateien
unterschiedliche Versionen haben und anhand der Zelle B106 unterschieden werden können.
Danke schonmal für eure Hilfe!
Tobi
Registriert seit: 17.07.2016
Version(en): 2016
Vielleicht zur Erklärung noch einmal vereinfacht dargestellt. Folgendes soll passieren:
1) Das Makro soll die erste Datei im ausgewählte Ordner öffnen und prüfen ob in Zelle B106 der Text "XYZ" vorkommt.
Wenn ja, dann soll Makro1 ausgeführt werden.
2) Wenn nein, dann soll Makro2 ausgeführt werden.
Und diese Routine dann für jede Datei, die das Makro öffnet.
Eventuell ist es jetzt besser zu verstehen.
Hoffe, mir kann jemand helfen.
Viele Grüße
Tobi
Registriert seit: 10.04.2014
Version(en): 97-2019 (32) + 365 (64)
Hallo Tobi,
welche ist denn die erste? die älteste? die neueste? die erste bei alphabetischer Sortierung? ...
Geht es um Exceldateien? Ich vermute es, da Du Daten aus verschiedenen in eine neue übernehmen willst. Ist die Zelle B106 in der Datei mit dem Makro oder, falls es Excel-Dateien sind, in der zu öffnenden? Wenn letzteres, auf welchem Blatt ist die Zelle B106? ...
. \\\|/// Hoffe, geholfen zu haben.
( ô ô ) Grüße, André aus G in T
ooO-(_)-Ooo (Excel 97-2019+365)
Registriert seit: 17.07.2016
Version(en): 2016
Hallo Andre,
möchte noch etwas Hintergrundinformationen geben.
Es gibt eine Datei, nennen wir Sie Zusammenfassung.xls wo die herausgelesenen Punkte aus den div. anderen Exceldateien (nennen wir Sie Datei1.xls + Datei2.xls usw. - die Anzahl kann unendlich sein) reinkopiert werden sollen. Das klappt auch mit meinem bisherigen Code (siehe unten) auch einwandfrei.
Nun haben wir das Problem, dass es aktuell zwei unterschiedliche Versionen der Datei1 und Datei2 gibt. Grundsätzlich werden in diesen Dateien die gleichen Daten aufgeführt - jedoch je nach Version in unterschiedlichen Zellen. Unterscheidbar sind die Versionen durch einen Eintrag in einer Zelle, z.Bsp. in der Datei1 steht in der Zelle B106=XY. In der Datei2.xls ist diese Zelle leer.
Somit soll das erste Makro prüfen, ob in der Zelle B106 der Datei1.xls etwas hinterlegt ist z.Bsp. der text "XY". Wenn ja --> Rufe Makro1 auf, welches
dann die jeweiligen Daten in dieser Datei anhand des Makro1 herauslist und in die Datei Zusammenfassung.xls schreibt. Wenn die Prüfung ergibt, dass B106 leer ist, dann führe Makro2 durch und lese die Daten aus und speicher Sie in die Datei Zusammenfassung.xls. Und dies für jede einzelne Datei die in diesem Ordner gespeichert ist.
Code: Option Explicit
Sub QAFsauswerten()
Dim strDateiname As String
Dim strPfad As String
Dim lngZeile As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "c:\" '"C:\Users\theodor\Desktop\testquaf"
.Title = "Ordner"
.ButtonName = "your Choice :)"
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strPfad = .SelectedItems(1)
If Right(strPfad, 1) <> "\" Then strPfad = strPfad & "\"
Else
strPfad = ""
End If
End With
If strPfad = "" Then
Exit Sub
Else
'Den 1. Dateinamen holen
strDateiname = Dir(strPfad & "*.xls")
'Startzeile festlegen
lngZeile = 2
'Solange ein Dateiname gelesen wird
Do While Not strDateiname = ""
'Datei verarbeiten
Call TabVerarb(strPfad & strDateiname, lngZeile)
'nächsten Dateinamen holen
strDateiname = Dir()
'Zeilenzähler erhöhen
lngZeile = lngZeile + 1
Loop
End If
End Sub
Public Sub TabVerarb(strPfad As String, lngZeile As Long)
Dim strMeSH As String
Dim strDatei As String
Dim strSH As String
'Dateinamen extrahieren
strDatei = Split(strPfad, "\")(UBound(Split(strPfad, "\")))
'Eigenen Namen merken
strMeSH = ActiveWorkbook.Name
'Datei öffnen
Workbooks.Open Filename:=strPfad
With Workbooks(strMeSH)
'Dateinamen und auszuwertenden Zellen übertragen
.Sheets("Tabelle1").Cells(lngZeile, 1) = strDatei
.Sheets("Tabelle1").Cells(lngZeile, 2) = Workbooks(strDatei).Sheets("Summary").Range("G16").Value
.Sheets("Tabelle1").Cells(lngZeile, 3) = Workbooks(strDatei).Sheets("Summary").Range("K8").Value
.Sheets("Tabelle1").Cells(lngZeile, 4) = Workbooks(strDatei).Sheets("Summary").Range("D27").Value
.Sheets("Tabelle1").Cells(lngZeile, 5) = Workbooks(strDatei).Sheets("Summary").Range("D26").Value
.Sheets("Tabelle1").Cells(lngZeile, 6) = Workbooks(strDatei).Sheets("Summary").Range("J27").Value
.Sheets("Tabelle1").Cells(lngZeile, 7) = Workbooks(strDatei).Sheets("Summary").Range("J28").Value
.Sheets("Tabelle1").Cells(lngZeile, 8) = Workbooks(strDatei).Sheets("Summary").Range("J29").Value
.Sheets("Tabelle1").Cells(lngZeile, 9) = Workbooks(strDatei).Sheets("Summary").Range("K29").Value
.Sheets("Tabelle1").Cells(lngZeile, 10) = Workbooks(strDatei).Sheets("Summary").Range("J31").Value
.Sheets("Tabelle1").Cells(lngZeile, 11) = Workbooks(strDatei).Sheets("Summary").Range("K31").Value
.Sheets("Tabelle1").Cells(lngZeile, 12) = Workbooks(strDatei).Sheets("Summary").Range("J32").Value
.Sheets("Tabelle1").Cells(lngZeile, 13) = Workbooks(strDatei).Sheets("Summary").Range("J35").Value
.Sheets("Tabelle1").Cells(lngZeile, 14) = Workbooks(strDatei).Sheets("Summary").Range("J37").Value
.Sheets("Tabelle1").Cells(lngZeile, 15) = Workbooks(strDatei).Sheets("Summary").Range("K37").Value
.Sheets("Tabelle1").Cells(lngZeile, 16) = Workbooks(strDatei).Sheets("Summary").Range("B40").Value
.Sheets("Tabelle1").Cells(lngZeile, 17) = Workbooks(strDatei).Sheets("Summary").Range("J48").Value
.Sheets("Tabelle1").Cells(lngZeile, 18) = Workbooks(strDatei).Sheets("Summary").Range("J49").Value
.Sheets("Tabelle1").Cells(lngZeile, 19) = Workbooks(strDatei).Sheets("Summary").Range("J57").Value
.Sheets("Tabelle1").Cells(lngZeile, 20) = Workbooks(strDatei).Sheets("Summary").Range("J64").Value
.Sheets("Tabelle1").Cells(lngZeile, 21) = Workbooks(strDatei).Sheets("Summary").Range("J65").Value
.Sheets("Tabelle1").Cells(lngZeile, 22) = Workbooks(strDatei).Sheets("Summary").Range("J66").Value
.Sheets("Tabelle1").Cells(lngZeile, 23) = Workbooks(strDatei).Sheets("Summary").Range("J72").Value
.Sheets("Tabelle1").Cells(lngZeile, 24) = Workbooks(strDatei).Sheets("Summary").Range("J73").Value
.Sheets("Tabelle1").Cells(lngZeile, 25) = Workbooks(strDatei).Sheets("Summary").Range("J74").Value
.Sheets("Tabelle1").Cells(lngZeile, 26) = Workbooks(strDatei).Sheets("Summary").Range("J80").Value
.Sheets("Tabelle1").Cells(lngZeile, 27) = Workbooks(strDatei).Sheets("Summary").Range("J82").Value
.Sheets("Tabelle1").Cells(lngZeile, 28) = Workbooks(strDatei).Sheets("Summary").Range("J83").Value
.Sheets("Tabelle1").Cells(lngZeile, 29) = Workbooks(strDatei).Sheets("Summary").Range("J84").Value
.Sheets("Tabelle1").Cells(lngZeile, 30) = Workbooks(strDatei).Sheets("Summary").Range("J93").Value
.Sheets("Tabelle1").Cells(lngZeile, 31) = Workbooks(strDatei).Sheets("Summary").Range("G94").Value
.Sheets("Tabelle1").Cells(lngZeile, 32) = Workbooks(strDatei).Sheets("Summary").Range("G95").Value
.Sheets("Tabelle1").Cells(lngZeile, 33) = Workbooks(strDatei).Sheets("Summary").Range("G98").Value
.Sheets("Tabelle1").Cells(lngZeile, 34) = Workbooks(strDatei).Sheets("Summary").Range("J103").Value
.Sheets("Tabelle1").Cells(lngZeile, 35) = Workbooks(strDatei).Sheets("Material").Range("E15").Value
.Sheets("Tabelle1").Cells(lngZeile, 36) = Workbooks(strDatei).Sheets("Material").Range("J15").Value
.Sheets("Tabelle1").Cells(lngZeile, 37) = Workbooks(strDatei).Sheets("Material").Range("O15").Value
.Sheets("Tabelle1").Cells(lngZeile, 38) = Workbooks(strDatei).Sheets("Material").Range("P15").Value
.Sheets("Tabelle1").Cells(lngZeile, 39) = Workbooks(strDatei).Sheets("Material").Range("Q15").Value
.Sheets("Tabelle1").Cells(lngZeile, 40) = Workbooks(strDatei).Sheets("Material").Range("R15").Value
.Sheets("Tabelle1").Cells(lngZeile, 41) = Workbooks(strDatei).Sheets("Material").Range("T15").Value
End With
'Quelldatei schließen
Workbooks(strDatei).Saved = True
Workbooks(strDatei).Close
End Sub
Habe versucht es zu verständlich wie möglich zu erklären - leider kann ich die Dateien nicht hochladen, da es berufliche Dateien sind.
Tobi
Registriert seit: 17.07.2016
Version(en): 2016
Hallo Andre,
konnte ich Dir die Sache näher bringen? Solltest du noch weitere Infos benötigen, sag einfach Bescheid.
Grüße
Tobi
Registriert seit: 10.04.2014
Version(en): 97-2019 (32) + 365 (64)
Hallo Tobi,
Du musst doch nur an passender Stelle die Prüfung einbauen.
If Sheets("Welchesauchimmer").Range("B106").value ="XY" Then Makro1 Else Makro2
. \\\|/// Hoffe, geholfen zu haben.
( ô ô ) Grüße, André aus G in T
ooO-(_)-Ooo (Excel 97-2019+365)
|