Eén file pakken uit de geselecteerde folder

Status
Niet open voor verdere reacties.
Roeland035

Roeland035

Gebruiker
Lid geworden
30 mrt 2015
Berichten
291
Beste forumleden,

Ik wil een macro toepassen op alle files in één folder.
Zover ben ik gelukkig al wel gekomen, maar nadat hij deze macro heeft toegepast op al deze files, moet hij nog één file pakken om daarvan de kolomtitels te pakken.

Momenteel heb ik dit (Het rode is de daadwerkelijke code om die file te selecteren), maar het werkt helaas niet.

Code: 
Sub Importeer_omloop()

Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
     
'Retrieve Target Folder Path From User
  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With FldrPicker
      .Title = "Select A Target Folder"
      .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        myPath = .SelectedItems(1) & "\"
    End With

'In Case of Cancel
NextCode:
  myPath = myPath
  If myPath = "" Then GoTo ResetSettings
  
  'Target File Extension (must include wildcard "*")
  myExtension = "*.xls"

'Target Path with Ending Extention
  myFile = Dir(myPath & myExtension)
  
  'Loop through each Excel file in folder
  Do While myFile <> ""
    'Set variable equal to opened workbook
      Set wb = Workbooks.Open(filename:=myPath & myFile, Local:=True)
      
    wb.Close True

    'Get next file name
      myFile = Dir
  Loop
  
[COLOR="#FF0000"]  If myFile = "" Then
    LatestFile = myFile
  
  Workbooks.Open (myPath & myFile)
  
              Range("a1:aj1").Select
            Selection.Copy
            
            'Return to target workbook
            Application.DisplayAlerts = False
            ActiveWorkbook.Close
            Application.DisplayAlerts = True
            
            Sheets("Input omloopsnelheidlijst").Select
            Range("A4").Select
            ActiveSheet.Paste
    End If[/COLOR]
'Message Box when tasks are completed
  MsgBox "Task Complete!"

ResetSettings:
  'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub
 
Hij mag bij wijze van spreken ook kijken naar de laatste datum. De kolomtitels zijn namelijk in elke file hetzelfde, dus het maakt niet uit welke hij pakt, zolang hij ze maar niet allemaal pakt.
Ik kan hem natuurlijk ook elke keer laten uitvoeren in de loop, maar dat lijkt mij een beetje onnodig en dubbelop.
 
Laatst bewerkt:
Roeland,

Je variabele Latestfile wordt pas gevuld als myFile leeg is met myFile, dus leeg. Daarna probeer je het bestand te openen.
wijzig je macro op de volgende punten
Code: 
'Target Path with Ending Extention
  myFile = Dir(myPath & myExtension)
  [COLOR="#FF0000"]LatestFile = myFile[/COLOR]
  'Loop through each Excel file in folder
  Do While myFile <> ""
    'Set variable equal to opened workbook
      Set wb = Workbooks.Open(filename:=myPath & myFile, Local:=True)
      
    wb.Close True

    'Get next file name
      myFile = Dir
  Loop
  
  If myFile = "" Then
    [COLOR="#FF0000"]myFile = LatestFile
[/COLOR]  
  Workbooks.Open (myPath & myFile)

Veel Succes
 
Elsendoorn2134 zei:
Roeland,

Je variabele Latestfile wordt pas gevuld als myFile leeg is met myFile, dus leeg. Daarna probeer je het bestand te openen.
wijzig je macro op de volgende punten
Code: 
'Target Path with Ending Extention
  myFile = Dir(myPath & myExtension)
  [COLOR="#FF0000"]LatestFile = myFile[/COLOR]
  'Loop through each Excel file in folder
  Do While myFile <> ""
    'Set variable equal to opened workbook
      Set wb = Workbooks.Open(filename:=myPath & myFile, Local:=True)
      
    wb.Close True

    'Get next file name
      myFile = Dir
  Loop
  
  If myFile = "" Then
    [COLOR="#FF0000"]myFile = LatestFile
[/COLOR]  
  Workbooks.Open (myPath & myFile)

Veel Succes
Klik om te vergroten...

Beste Elsendoorn2134,

Ik heb je wijzigingen toegepast en heb nu het volgende: (Ik heb de macro alweer uitgebreid zodat hij ook daadwerkelijk iets doet in die loop.
Code: 
Sub Importeer_omloop()

Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim wsS1 As Worksheet
Dim lastrow As Long
Dim lastrow2 As Long
     
'Retrieve Target Folder Path From User
  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With FldrPicker
      .Title = "Select A Target Folder"
      .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        myPath = .SelectedItems(1) & "\"
    End With

'In Case of Cancel
NextCode:
  myPath = myPath
  If myPath = "" Then GoTo ResetSettings
  
  'Target File Extension (must include wildcard "*")
  myExtension = "*.xls"

'Target Path with Ending Extention
  myFile = Dir(myPath & myExtension)
  LatestFile = myFile
  
  'Loop through each Excel file in folder
  Do While myFile <> ""
    'Set variable equal to opened workbook
            
      Set wb = Workbooks.Open(filename:=myPath & myFile, Local:=True)
            Set wsS1 = ActiveSheet
                With wsS1
                    lastrow = Range("A" & Rows.Count).End(xlUp).Row
                    wsS1.Range("A2:AJ" & lastrow).Copy
                End With
                
            'Return to target workbook
            Application.DisplayAlerts = False
            ActiveWorkbook.Close
            Application.DisplayAlerts = True

            Sheets("Input omloopsnelheidlijst").Select
            lastrow2 = Range("A" & Rows.Count).End(xlUp).Row
            Range("A" & lastrow2).Select
            ActiveSheet.Paste
            
    'Get next file name
      myFile = Dir
  Loop
  
    If myFile = "" Then
    myFile = LatestFile
  
  Workbooks.Open (myPath & myFile)
  
              Range("a1:aj1").Select
            Selection.Copy
            
            'Return to target workbook
            Application.DisplayAlerts = False
            ActiveWorkbook.Close
            Application.DisplayAlerts = True
            
            Sheets("Input omloopsnelheidlijst").Select
            Range("A4").Select
            ActiveSheet.Paste
    End If

'Message Box when tasks are completed
  MsgBox "Task Complete!"

ResetSettings:
  'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

Kan je mij misschien helpen met deze code waar wij mee bezig waren boven de loop te zetten in plaats van eronder?
De loop plaatst namelijk data van files onder de eerst volgende (lege) rij en die gevulde rij met kolomtitels komt nu pas nadat die de data er in plakt.
 
Roeland,

Probeer de volgende code eens,

Code: 
Sub Importeer_omloop()

Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim wsS1 As Worksheet
Dim lastrow As Long
Dim lastrow2 As Long
Dim isFirst As Boolean
     
isFirst = True
     
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

With FldrPicker
    .Title = "Select A Target Folder"
    .AllowMultiSelect = False
    If .Show <> -1 Then GoTo ResetSettings  'Als geanuleerd dan afsluiten
    myPath = .SelectedItems(1) & "\"
End With

'Target File Extension (must include wildcard "*")
myExtension = "*.xls"

'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
  
'Loop through each Excel file in folder
Do While myFile <> ""
    'Set variable equal to opened workbook
            
    Set wb = Workbooks.Open(Filename:=myPath & myFile, Local:=True)
    Set wsS1 = ActiveSheet
    With wsS1
        lastrow = .Range("A" & Rows.Count).End(xlUp).Row
        If isFirst Then
            .Range("A1:AJ" & lastrow).Copy
            isFirst = False
        Else
            .Range("A2:AJ" & lastrow).Copy
        End If
    End With
    'Return to target workbook
    wb.Close SaveChanges:=False

    Sheets("Input omloopsnelheidlijst").Select
    lastrow2 = Range("A" & Rows.Count).End(xlUp).Row
    Range("A" & lastrow2).Select
    ActiveSheet.Paste
            
    'Get next file name
    myFile = Dir
Loop

'Message Box when tasks are completed
MsgBox "Task Complete!"

ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Als het eerste bestand gekopieerd wordt zal hij de eerste regel ook meenemen bij alle andere bestanden
zal hij vanaf A2 kopiëren.

Veel Succes.
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan