Hallo,
Kan iemand mij helpen.
Ik gebruik deze macro voor het samenvoegen van meerdere excel files. Het werkt prima bij minder dan 10 bestanden.
Ik heb deze gebruikt voor het samenvoegen van ongeveer 120 bestanden maar hij stopt voordat deze klaar is. De macro file wordt dan afgesloten.
Hoe kan ik dit oplossen
Alvast bedankt
Kan iemand mij helpen.
Ik gebruik deze macro voor het samenvoegen van meerdere excel files. Het werkt prima bij minder dan 10 bestanden.
Ik heb deze gebruikt voor het samenvoegen van ongeveer 120 bestanden maar hij stopt voordat deze klaar is. De macro file wordt dan afgesloten.
Hoe kan ik dit oplossen
Alvast bedankt
Code:
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 = "A:\Afdelingen\ " ' Map met .xlsx-bestanden
intCounter = 1 ' teller
strWorkbook(intCounter) = Dir(strPath & "*.xlsx")
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:=False) '
Application.DisplayAlerts = False
'Application.ActiveProtectedViewWindow.Edit
If ActiveWorkbook.MultiUserEditing Then
ActiveWorkbook.ExclusiveAccess
End If
ActiveSheet.Unprotect Password:="12345"
Application.DisplayAlerts = False
Sheets(Array("blad2", "blad3", "blad4")).Select
Sheets("blad4").Activate
ActiveWindow.SelectedSheets.Delete
Range("N1").Select
Sheets("blad1").Select
ActiveSheet.Range("$A$6:$AQ$10000").AutoFilter Field:=4, Criteria1:=">0", _
Operator:=xlAnd
ActiveSheet.ShowAllData
Rows("1:5").Select Selection.Delete Shift:=xlUp
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
MyName = Range("A1").Value & "File samengevoegd" & Range("A1").Value
ChDir "A:\Afdelingen\"
ActiveWorkbook.SaveAs Filename:=MyName & ".xlsx" _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Laatst bewerkt:
