• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Plakken waarden in plaats van Destination

Status
Niet open voor verdere reacties.

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:
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?
 
Status
Niet open voor verdere reacties.
Terug
Bovenaan Onderaan