Ik heb deze code gevonden op dit forum. Deze code werkte 1x maal met bestanden doe toevallig in een map stonden. Nadat ik de bestands directory in de VBA code aangepast heb naar de directory H:\Mijn documenten\Downloads\123 werkte deze niet meer.
Ik verwijs nu naar : H:\Mijn documenten\Downloads\123 zoals in de code aangegeven. Ik heb in die map 3 test bestanden aangemaakt met allen verschillende tekst.
Dienen de bestanden aan bepaalde voorwaarden of specifieke eigenschappen te voldoen ?
Hieronder de code
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Sub VoegExcelBestandenSamenIn1NieuwBlad()
' [TOPIC=848630///][NOHTML][rml][ Excel] Meerdere bestanden samenvoegen[/rml][/NOHTML][/TOPIC]
' deel 2
Dim wbSingleWorkbook As Excel.Workbook, wbFinalWorkbook As Excel.Workbook
Dim wsSingleSheet As Excel.Worksheet, wsFinalSheet As Excel.Worksheet
Dim strPath As String, strWorkbook(500) As String ' max 500 bestanden
Dim intCounter As Integer, n As Integer
Dim Answer As VbMsgBoxResult
strPath = "H:\Mijn documenten\Downloads\123" ' Map met .xls-bestanden
intCounter = 1 ' teller
strWorkbook(intCounter) = Dir(strPath & "*.xls")
Do While strWorkbook(intCounter) <> ""
intCounter = intCounter + 1
strWorkbook(intCounter) = Dir
Loop
intCounter = intCounter - 1 ' want de laatste is leeg
Set wbFinalWorkbook = Workbooks.Add
Application.DisplayAlerts = False
Do While wbFinalWorkbook.Sheets.Count > 1
wbFinalWorkbook.Sheets(1).Delete
Loop ' We hebben maar 1 blad nodig
Application.DisplayAlerts = True
Set wsFinalSheet = wbFinalWorkbook.Sheets(1)
On Error GoTo Einde ' Error trapping AAN
For n = 1 To intCounter
Set wbSingleWorkbook = Workbooks.Open(Filename:=strPath _
& strWorkbook(n), ReadOnly:=True)
For Each wsSingleSheet In wbSingleWorkbook.Sheets
wsSingleSheet.UsedRange.Copy _
Destination:=wsFinalSheet.Cells _
(wsFinalSheet.Cells.SpecialCells _
(xlCellTypeLastCell).Row + 1, 1)
Next wsSingleSheet
wbSingleWorkbook.Close
Next n
On Error GoTo 0 ' Error trapping UIT
Einde:
Select Case Err.Number ' Foutmelding 1004 is
' hoogstwaarschijnlijk veroorzaakt
Case 1004 ' door iets te plakken dat boven
' de 65536 rijen uit zou komen
Answer = MsgBox(Err.Description & Chr(13) & Chr(13) & _
"Waarschijnlijk wordt dit bestand te groot..." & _
Chr(13) & "Verder gaan op nieuw blad?", _
vbCritical Or vbYesNo, "Error " & Err.Number & _
": " & Err.Description)
If Answer = vbYes Then
Set wsFinalSheet = wbFinalWorkbook.Sheets.Add
Resume
End If
Case 0 ' Niks aan 't handje
Case Else ' Overige foutmeldingen
MsgBox Err.Description, _
vbCritical Or vbOKOnly, "Error " & Err.Number & _
" in bestand " & n
End Select
Set wbSingleWorkbook = Nothing
Set wbFinalWorkbook = Nothing
Set wsSingleSheet = Nothing
Set wsFinalSheet = Nothing
End Sub
