Erik191283
Gebruiker
- Lid geworden
- 13 mei 2015
- Berichten
- 49
Een aantal jaar geleden heb ik vanaf dit forum een heel mooi stukje code gekopieerd en tot afgelopen maand heb ik dit ook goed kunnen gebruiken.
De code kopieert van zo'n 30 bestanden 12 tabbladen per bestand allemaal naar 1 bestand zodat ik met de totale gegevens aan de slag kan.
Nu is in de 30 bestanden iets veranderd waardoor er verwijzingen in zitten naar andere bestanden. Dit gaat niet goed met kopieren en ik vermoed ook dat ik weet waarom, maar ik krijg het niet opgelost.
De oorspronkelijke code is:
Mijns inziens moet in het volgende stukje code het Destination deel gewijzigd worden naar PasteValue, maar ik krijg het niet voor elkaar:
Weet iemand hoe ik dit op kan lossen?
De code kopieert van zo'n 30 bestanden 12 tabbladen per bestand allemaal naar 1 bestand zodat ik met de totale gegevens aan de slag kan.
Nu is in de 30 bestanden iets veranderd waardoor er verwijzingen in zitten naar andere bestanden. Dit gaat niet goed met kopieren en ik vermoed ook dat ik weet waarom, maar ik krijg het niet opgelost.
De oorspronkelijke code is:
Code:
Sub VoegExcelBestandenSamenIn1NieuwBlad()
' [TOPIC=848630///][NOHTML][rml][ Excel] Meerdere bestanden samenvoegen[/rml][/NOHTML][/TOPIC]
' deel 2
Application.ScreenUpdating = False
Stap1
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 = "J:\Test\" ' 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 SaveChanges:=False
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
Draaitable
Afdruk
Application.ScreenUpdating = True
End Sub
Mijns inziens moet in het volgende stukje code het Destination deel gewijzigd worden naar PasteValue, maar ik krijg het niet voor elkaar:
Code:
For Each wsSingleSheet In wbSingleWorkbook.Sheets
wsSingleSheet.UsedRange.Copy _
Destination:=wsFinalSheet.Cells _
(wsFinalSheet.Cells.SpecialCells _
(xlCellTypeLastCell).Row + 1, 1)
Next wsSingleSheet
Weet iemand hoe ik dit op kan lossen?