gevens in een andere cel plaatsen

Status
Niet open voor verdere reacties.

71peerke

Gebruiker
Lid geworden
25 nov 2017
Berichten
5
Onderstaande code heb ik de laatste dagen in elkaar geklust (zeg maar geprutst :) )

wat ik wil en nog niet voor elkaar krijg

is dat voordat de loop begint de range B26 : D40 leeg gemaakt word
en dat de waardes worden geplaatst beginnende op B26 ipv in Kolom E rij 2

Code:
Sub MergeAllWorkbooks()
    Dim Reportwb As Workbook
    Dim FolderPath As String
    Dim FileName As String
    Dim WorkBk As Workbook
    Dim SourceRange As Range
    Dim DestRange As Range
  
    Application.ScreenUpdating = False
    ' Set summarysheet to activeworkbook/activesheet where the macro runs
    Set Reportwb = ThisWorkbook
    
    ' Modify this folder path to point to the files you want to use.
    FolderPath = "D:\diverse\test\"
    
    ' Call Dir the first time, pointing it to all Excel files in the folder path.
    FileName = Dir(FolderPath & "werkmap *.xl*")
    

    ' Loop until Dir returns an empty string.
    Do While FileName <> ""
        ' Open a workbook in the folder
        Set WorkBk = Workbooks.Open(FolderPath & FileName)

        'loop through all Sheets in WorkBk
          
        ' Set the source range to be A1 through C1.
          Set SourceRange = Sheets("All").Range("A1:C1")
        
        ' Set the destination range to start at column E and
        Set DestRange = Reportwb.Sheets("Blad1").Range("E" & Reportwb.Sheets("Blad1").Range("E" & Rows.Count).End(xlUp).Row + 1)
        Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
           SourceRange.Columns.Count)
        
        ' Copy over the values from the source to the destination.
        DestRange.Value = SourceRange.Value
        
        ' Close the source workbook without saving changes.
        WorkBk.Close savechanges:=False
        
        ' Use Dir to get the next file name.
        FileName = Dir()
    Loop
    
    ' Call AutoFit on the destination sheet so that all
    ' data is readable.
    ActiveSheet.Columns.AutoFit
End Sub

Kan iemand me opweg helpen naar de oplossting
 
een snelle poging:

Code:
Sub MergeAllWorkbooks()
    Dim Reportwb As Workbook
    Dim FolderPath As String
    Dim FileName As String
    Dim WorkBk As Workbook
    Dim SourceRange As Range
    Dim DestRange As Range
  
    Application.ScreenUpdating = False
    ' Set summarysheet to activeworkbook/activesheet where the macro runs
    Set Reportwb = ThisWorkbook
    
    ' Modify this folder path to point to the files you want to use.
    FolderPath = "D:\diverse\test\"
    
    ' Call Dir the first time, pointing it to all Excel files in the folder path.
    FileName = Dir(FolderPath & "werkmap *.xl*")
    

    ' Loop until Dir returns an empty string.
    Do While FileName <> ""
        ' Open a workbook in the folder
        Set WorkBk = Workbooks.Open(FolderPath & FileName)

        'loop through all Sheets in WorkBk
          
        ' Set the source range to be A1 through C1.
          Set SourceRange = Sheets("All").Range("A1:C1")
        
        ' Set the destination range to start at column E and
        Reportwb.Sheets("Blad1").Range("B26:D40").ClearContents
        
        If Reportwb.Sheets("Blad1").Range("B26").Value = "" Then
        
            Set DestRange = Reportwb.Sheets("Blad1").Range("B26")
        Else
            Set DestRange = Reportwb.Sheets("Blad1").Cells(Reportwb.Sheets("Blad1").Range("B" & Rows.Count).End(xlUp).Row + 1, 2)
        End If
        
        ' Copy over the values from the source to the destination.
        DestRange.Value = SourceRange.Value
        
        ' Close the source workbook without saving changes.
        WorkBk.Close savechanges:=False
        
        ' Use Dir to get the next file name.
        FileName = Dir()
    Loop
    
    ' Call AutoFit on the destination sheet so that all
    ' data is readable.
    ActiveSheet.Columns.AutoFit
End Sub
 
Dank Sjon

heb de clear opdracht uit de loop gehaald dat lijkt beter te gaan nu :)

de eerste rij B26 tot D26 word gevuld met de juiste gegevens
de daar op volgende rijen word alleen de B kolom gevuld kolom en
heb de
Set DestRange = Reportwb.Sheets("Blad1").Cells(Reportwb.Sheets("Blad1").Range("B" & Rows.Count).End(xlUp).Row + 1,
veranderd
Set DestRange = Reportwb.Sheets("Blad1").Cells(Reportwb.Sheets("Blad1").Range("B26:D26" & Rows.Count).End(xlUp).Row + 1,
dit word niet geaccepteerd Fout 1004 object gedefineerde fout




Code:
Sub MergeAllWorkbooks()
    Dim Reportwb As Workbook
    Dim FolderPath As String
    Dim FileName As String
    Dim WorkBk As Workbook
    Dim SourceRange As Range
    Dim DestRange As Range
  
    Application.ScreenUpdating = False
    ' Set summarysheet to activeworkbook/activesheet where the macro runs
    Set Reportwb = ThisWorkbook
    
    ' Modify this folder path to point to the files you want to use.
    FolderPath = "D:\diverse\test\"
    
    ' Call Dir the first time, pointing it to all Excel files in the folder path.
    FileName = Dir(FolderPath & "werkmap *.xl*")
    

    ' Loop until Dir returns an empty string.
    Do While FileName <> ""
        ' Open a workbook in the folder
        Set WorkBk = Workbooks.Open(FolderPath & FileName)


        ' Set the destination range to start at column B and
        'Reportwb.Sheets("Blad1").Range("B26:D40").ClearContents

        'loop through all Sheets in WorkBk
          
        ' Set the source range to be A1 through C1.
          Set SourceRange = Sheets("All").Range("A1:C1")
   
        
        If Reportwb.Sheets("Blad1").Range("B26").Value = "" Then
        
            Set DestRange = Reportwb.Sheets("Blad1").Range("B26")
        Else
            Set DestRange = Reportwb.Sheets("Blad1").Cells(Reportwb.Sheets("Blad1").Range("B" & Rows.Count).End(xlUp).Row + 1, 2)
        End If
        
        ' Copy over the values from the source to the destination.
        DestRange.Value = SourceRange.Value
        
        ' Close the source workbook without saving changes.
        WorkBk.Close savechanges:=False
        
        ' Use Dir to get the next file name.
        FileName = Dir()
    Loop
    
    ' Call AutoFit on the destination sheet so that all
    ' data is readable.
    ActiveSheet.Columns.AutoFit
End Sub
 
Dit kan natuurlijk helemaal niet:
Code:
.Range("B26:D26" & Rows.Count).End(xlUp).Row

Dat is een niet bestaande range en krijg je die 1004 foutmelding op.
 
Dit kan natuurlijk helemaal niet:
Code:
.Range("B26:D26" & Rows.Count).End(xlUp).Row

Dat is een niet bestaande range en krijg je die 1004 foutmelding op.

Dat begrijp Edmoor
maar wat ik niet begrijp dat de eerste rij wel 3 kolommen gevuld word, maar bij de volgende rij maar 1 kolom
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan