Probleem met kopiëren werkboek excel

[mastermk]

Hallo Allemaal,

Ik ben nieuw hier, en ik hoop dat jullie mij kunnen helpen.

Ik heb hieronder een stukje code wat van een excelbestand bepaalde kolommen moet kopiëren richting een actief excelbestand (via een button getriggerd)

Het lijkt of er een selectie actief blijft van 4489 rijen. En deze krijg ik er niet uit. Hij blijft dus aanvullen tot rij 4489 wat dus dubbele data oplevert.

Ik zit er nu al een tijd naar te kijken maar krijg het zo snel niet gevonden hoe dit op te lossen.


Hebben julile enig idee. Alvast erg bedankt voor het kijken.

Mvg Mark

Sub CopySameSheetFrmWbs()
    Dim wbOpen As Workbook
    Dim lCol As Long, lRow As Long
     'Change Path
    Const strPath As String = "C:\Data\"
    Dim strExtension As String
     
     'Comment out the 3 lines below to debug
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    On Error Resume Next
     
    ChDir strPath
     'Change extension
    strExtension = Dir("*.xlsm")
               
    Do While strExtension <> ""
        Set wbOpen = Workbooks.Open("C:\Data\data.xls")
         With wbOpen.Sheets(1)
            For lCol = 7 To 11
                .Range(Cells(1, lCol), .Cells(.Rows.count, lCol).End(xlUp)).Copy
                ThisWorkbook.Sheets(2).Cells _
                (.Rows.count, lCol).End(xlUp)(1, 1).PasteSpecial xlValues
                 ThisWorkbook.Sheets(2).Cells _
                (.Rows.count, lCol).End(xlUp)(1, 1).PasteSpecial xlFormats
                Application.CutCopyMode = False
            Next lCol
            wbOpen.Close
        End With
         
        strExtension = Dir
    Loop
     
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    On Error GoTo 0
End Sub

 

[Elsendoorn2134]

Mark,

Volgens bijgaande code kijk je iedere keer in hetzelfde bestand, namelijk C:\Data\data.xls.
Ik vermoed dat je een aantal bestanden achter elkaar wilt openen.
Namelijk alle *.xlsm bestanden in de huidige subdirectory.
Gebruik hiervoor
Set wbOpen = Workbooks.Open(strExtension)

Veel Succes.