Bestanden samevoegen met Filename als Kolom

[DarioKeizer]

Hallo allemaal,

Ik ben op zoek naar een manier om een hele lijst aan bestanden samen te voegen in Excel (zie Macro 1) en daarbij de bestandsnamen als kolom te vullen in het totaalbestand (zie Macro 2).
Op dit moment heb ik 2 Macro's waarbij ik in losse stappen het resultaat bereik.

Wie weet een manier om deze 2 functionaliteiten samen te voegen tot 1 macro?



_________________MACRO 1_________________

Sub MergeAll()
Dim bookList As Workbook
Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
Application.ScreenUpdating = False
Set mergeObj = CreateObject("Scripting.FileSystemObject")

Set dirObj = mergeObj.Getfolder("C:\Mijn Documenten\ImportBestanden")
Set filesObj = dirObj.Files
For Each everyObj In filesObj
Set bookList = Workbooks.Open(everyObj)

Range("A1:IV" & Range("A65536").End(xlUp).Row).Copy
ThisWorkbook.Worksheets(1).Activate

Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial
Application.CutCopyMode = False
bookList.Close
Next

End Sub


_________________MACRO 2_________________


Sub FileNameAsColumn()


‘plek waar de bestandnaam dient te komen
Range("BH2").Select

ActiveCell.FormulaR1C1 = "=REPLACE(LEFT(CELL(""filename""),SEARCH(""]"",CELL(""filename""))-1),1,SEARCH(""["",CELL(""filename"")),"""")"



Range("A2").Select

Selection.End(xlDown).Select

ActiveCell.Offset(0, 59).Select

Range(Selection, Selection.End(xlUp)).Select

Selection.FillDown




Columns("BH:BH").Select

Selection.Copy

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False



ActiveWorkbook.Save

ActiveWorkbook.Close



End Sub

 

[VenA]

Wat is de vraag? Waarom geen codetags? Dit is een totaal onleesbaar zooitje.

 

[HSV]

Ik zal je op weg helpen @VenA.

Wat is de vraag?

Op dit moment heb ik 2 Macro's waarbij ik in losse stappen het resultaat bereik.

Wie weet een manier om deze 2 functionaliteiten samen te voegen tot 1 macro?

 

[edmoor]

In macro MergeAll()
CALL FileNameAsColumn

Net voor de Next in de eerste macro.

NB:
Dat is inderdaad niet een manier om leesbaar code te plaatsen.
Daar zijn de Codetags voor.
Al die onnodige lege regels in een macro helpen ook niet.

 

[Ginger]

Ehhhh.... Waarom in VBA een complexe formule op de sheet plaatsen...
ActiveCell.FormulaR1C1 = "=REPLACE(LEFT(CELL(""filename""),SEARCH(""]"",CELL(""filename""))-1),1,SEARCH(""["",CELL(""filename"")),"""")"
...als je die bestandsnaam in 1x kan achterhalen met iets van ActiveWorkbook.Name? Volgens mij heb je 'm zelfs al te pakken met je variabele everyObj

 

[DarioKeizer]

In macro MergeAll()
CALL FileNameAsColumn

Net voor de Next in de eerste macro.

NB:
Dat is inderdaad niet een manier om leesbaar code te plaatsen.
Daar zijn de Codetags voor.
Al die onnodige lege regels in een macro helpen ook niet.

@ Edmoor Bedankt,

Heb het geprobeerd met Call FileNameAsColumn
Maar dat blijkt helaas ook niet te lukken.

Heb je een idee hoe ik een kolom kan aanwijzen waar iedere keer per geïmporteerd bestand in de rijen de bestandsnaam wordt getoond?
In onderstaande afbeelding zou de bestandsnaam dan in kolom [E] terecht komen.




Sub MergeAll()
Dim bookList As Workbook
Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
Application.ScreenUpdating = False
Set mergeObj = CreateObject("Scripting.FileSystemObject")

Set dirObj = mergeObj.Getfolder("C:\Mijn Documenten\ImportBestanden")
Set filesObj = dirObj.Files
For Each everyObj In filesObj
Set bookList = Workbooks.Open(everyObj)

Range("A1:IV" & Range("A65536").End(xlUp).Row).Copy
ThisWorkbook.Worksheets(1).Activate

Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial
Application.CutCopyMode = False
bookList.Close
Call FileNameAsColumn
Next

End Sub

 

[edmoor]

Doe dit maar eens in een leeg document, dan zal je zien dat het gewoon werkt:

Sub MergeAll()
    MsgBox "MergeAll"
    Call FileNameAsColumn
End Sub

Sub FileNameAsColumn()
    MsgBox "FileNameAsColumn"
End Sub

Klik dus op de eerste MsgBox regel en druk dan op F5.

Edit:
Je bijlage in #8 is er niet.

 

[DarioKeizer]

Vraag opgelost

Beste allen,

Online heb ik onderstaande code gevonden. Deze werkt prima. Bedankt nog voor het meedenken !


Sub MergeAllWorkbooks()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, FNum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long

' Change this to the path\folder location of your files.
MyPath = "C:\Users\Ron\test"

' Add a slash at the end of the path if needed.
If Right(MyPath, 1) <> "" Then
MyPath = MyPath & ""
End If

' If there are no Excel files in the folder, exit.
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If

' Fill the myFiles array with the list of Excel files
' in the search folder.
FNum = 0
Do While FilesInPath <> ""
FNum = FNum + 1
ReDim Preserve MyFiles(1 To FNum)
MyFiles(FNum) = FilesInPath
FilesInPath = Dir()
Loop

' Set various application properties.
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With

' Add a new workbook with one sheet.
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1

' Loop through all files in the myFiles array.
If FNum > 0 Then
For FNum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
On Error GoTo 0

If Not mybook Is Nothing Then
On Error Resume Next

' Change this range to fit your own needs.
With mybook.Worksheets(1)
Set sourceRange = .Range("A1:C1")
End With

If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
' If source range uses all columns then
' skip this file.
If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0

If Not sourceRange Is Nothing Then

SourceRcount = sourceRange.Rows.Count

If rnum + SourceRcount >= BaseWks.Rows.Count Then
MsgBox "There are not enough rows in the target worksheet."
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else

' Copy the file name in column A.
With sourceRange
BaseWks.Cells(rnum, "A"). _
Resize(.Rows.Count).Value = MyFiles(FNum)
End With

' Set the destination range.
Set destrange = BaseWks.Range("B" & rnum)

' Copy the values from the source range
' to the destination range.
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value

rnum = rnum + SourceRcount
End If
End If
mybook.Close savechanges:=False
End If

Next FNum
BaseWks.Columns.AutoFit
End If

ExitTheSub:
' Restore the application properties.
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub

 

[VenA]

Lijkt mij hier al fout te gaan.

MyPath = "C:\Users\Ron\test"

' Add a slash at the end of the path if needed.
If Right(MyPath, 1) <> "" Then
MyPath = MyPath & ""
End If

Een mogelijk alternatief voor de totaal onleesbare code in #8

Sub VenA()
c00 = "C:\Users\Ron\test"
Application.ScreenUpdating = False
  For Each fl In CreateObject("scripting.filesystemobject").Getfolder(c00).Files
    With GetObject(fl)
      ar = .Sheets(1).UsedRange
      .Close False
     End With
     ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(ar), UBound(ar, 2)) = ar
    End If
  Next fl
End Sub