Sheets samenvoegen, gegevens overschrijden elkaar

[phwac]

Hallo Iedereen,


Ik heb op het internet een snipet macro code gevonden dat alle sheets consolideerd. Ik heb deze macro deels aangepast, zie:

Sub Combine()
    Dim J As Integer

    On Error Resume Next

' Select sheet two
    Sheets(2).Select

' Add a sheet left from sheet 2
    Worksheets.Add

' Name the new sheet Geconsolideerd
    Sheets(2).Name = "Geconsolideerd"

' Go to sheet 3
    Sheets(3).Activate

' Select header of sheet 3
    Range("A1").EntireRow.Select
    
' Copy header from sheet 3 and paste it in sheet Export sBU Geconsolideerd
    Selection.Copy Destination:=Sheets(2).Range("A1")

' work through sheets
    For J = 3 To Sheets.Count ' from sheet 2 to last sheet
        Sheets(J).Activate ' make the sheet active
        Range("A2").Select
        Selection.CurrentRegion.Select ' select all cells in this sheets

        ' select all lines except title
        Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select

        ' copy cells selected in the new sheet on last line
        Selection.Copy Destination:=Sheets(2).Range("A65536").End(xlUp)(2)
    Next
End Sub

Hierin zijn de volgende stappen te zien:

1. Maak sheet genaamd: geconsolideerd aan
2. Ga alle sheets langs die rechts vanaf de sheet geconsolideerd zijn
3. Selecteer de header van sheet 3, en plak die in sheet geconsolideerd
4. Ga eenmalig terug naar sheet 3, selecteer gehele werkblad behalve bovenste rij.
5. Plak deze gegevens in sheet Geconsolideerd, ga verder met alle resterende sheets.

Het probleem zit hem in het volgende:
- Na selectie van sheet 3 plakt die de gegevens in sheet Geconsolideerd (moet ook!)
- Daarna gaat het script naar sheet 4 en selecteert die het gehele werkblad behalve de bovenste rij, maar nu plakt die de gegevens over de net geplaatste gegevens in sheet Geconsolideerd.


Ik wil dat de macro eerst kijkt welke rij leeg is en dan de volgende gegevens plaatst, zodat de gegevens niet elkaar overschrijden.
Welke code heb ik hiervoor nodig, om dit voor melkaar te krijgen?

Bijlage:
Bekijk bijlage helpmij.xlsm

 

[ReneDirks]

Probeer het eens met zoiets (kan zijn dat je 'm nog wat moet aanpassen)

Sub Combine()
    Dim J As Integer
    Dim iRow As Integer

    On Error Resume Next

' Select sheet two
    Sheets(2).Select

' Add a sheet left from sheet 2
    Worksheets.Add

' Name the new sheet Geconsolideerd
    Sheets(2).Name = "Geconsolideerd"

' Go to sheet 3
    Sheets(3).Activate

' Select header of sheet 3
    Range("A1").EntireRow.Select
    
' Copy header from sheet 3 and paste it in sheet Export sBU Geconsolideerd
    Selection.Copy Destination:=Sheets(2).Range("A1")

iRow = 2

' work through sheets
    For J = 3 To Sheets.Count ' from sheet 2 to last sheet
        Sheets(J).Activate ' make the sheet active
        Range("A2").Select
        Selection.CurrentRegion.Select ' select all cells in this sheets

        ' select all lines except title
        Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
        
        ' copy cells selected in the new sheet on last line
        'Selection.Copy Destination:=Sheets(2).Range("A65536").End(xlUp)(2)
        Selection.Copy Destination:=Sheets(2).Cells(iRow, 1)
        iRow = iRow + Selection.Rows.Count
    Next
End Sub

 

[phwac]

Hoi Rene
Heb het snel uitgeprobeerd,
Nu pakt die alleen de eerste en tweede sheet, daarna gaat die niet verder

 

[ReneDirks]

Zo dan? Bij het plakken klopt de selectie niet meer. Deze ziet er nu een beetje raar uit omdat er geen data in je sheets staat, maar wel een 500+ opgemaakte regels, die dus netjes overgezet worden. In de consolidatie dus even scrollen, of je moet je selectie statement aanpassen dat er geen lege regels gekopieerd worden.

Sub Combine()
    Dim J As Integer
    Dim iRow As Integer
    Dim iRowsSelected As Integer

    On Error Resume Next

' Select sheet two
    Sheets(2).Select

' Add a sheet left from sheet 2
    Worksheets.Add

' Name the new sheet Geconsolideerd
    Sheets(2).Name = "Geconsolideerd"

' Go to sheet 3
    Sheets(3).Activate

' Select header of sheet 3
    Range("A1").EntireRow.Select
    
' Copy header from sheet 3 and paste it in sheet Export sBU Geconsolideerd
    Selection.Copy Destination:=Sheets(2).Range("A1")

iRow = 2

' work through sheets
    For J = 3 To Sheets.Count ' from sheet 2 to last sheet
        Sheets(J).Activate ' make the sheet active
        Range("A2").Select
        Selection.CurrentRegion.Select ' select all cells in this sheets

        ' select all lines except title
        Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
        iRowsSelected = Selection.Rows.Count
        
        ' copy cells selected in the new sheet on last line
        'Selection.Copy Destination:=Sheets(2).Range("A65536").End(xlUp)(2)
        Selection.Copy Destination:=Sheets(2).Cells(iRow, 1)
        iRow = iRow + iRowsSelected
    Next
End Sub

 

[pasan]

en op deze manier?

Sub Combine2()
    Dim J As Integer
    
    On Error Resume Next

' Add a sheet left from sheet 2
   ThisWorkbook.Sheets.Add After:=Sheets(1)

' Name the new sheet Export sBU Geconsolideerd
    Sheets(2).Name = "Export sBU Geconsolideerd"

'  sheet 3
    Sheets(3).Rows("1").Copy Sheets(2).Rows("1")


' work through sheets
    For J = 3 To Sheets.Count ' from sheet 2 to last sheet

     With Sheets(J).Range("A1").CurrentRegion.Offset(1, 0)
        .Copy Sheets(2).Range("B65536").End(xlUp)(2).Offset(, -1)
     End With
 
   Next

   With Sheets(2)
   .Columns.AutoFit
   .ListObjects.Add(xlSrcRange, Range("$A$1").CurrentRegion, , xlYes).Name = "Geconsolideerd"
   End With
    
End Sub

 

[phwac]

Rene, je laatste Macro werkt, bedankt!
Pasan, die van jouw werkt helemaal, nu hoef ik geen aparte macro te draaien om de regels er tussen uit te halen!

Bedankt beide, dit gaat mijn werk een stuk aangenamer maken.

Groetjes,
Phwac

 

[snb]

of

Sub M_snb()
   With ThisWorkbook.Sheets.Add(, Sheets(1))
      .Name = "Export sBU Geconsolideerd"
      .Cells(1).Resize(, Sheets("Blad3").Rows(1).SpecialCells(2).Count) = Sheets("Blad3").Rows(1).SpecialCells(2).Value

      For Each sh In Sheets
        if sh.name<>.name then .Cells(Rows.Count, 2).End(xlUp).Offset(2, -1).Resize(sh.Cells(1).CurrentRegion.Rows.Count, sh.Cells(1).CurrentRegion.Columns.Count) = sh.Cells(1).CurrentRegion.Value
      Next

      .Columns.AutoFit
      .ListObjects.Add(xlSrcRange, Range("$A$1").CurrentRegion, , xlYes).Name = "Geconsolideerd"
   End With
End Sub

Vermijd het indexnummer van werkbladen want dat is niet constant.

 

[phwac]

Beste snB, ik begrijp niet goed wat u bedoeld.

Beste Pasan, is er ook een mogelijkheid dat de Macro eerst checkt of er al een sheet: Export sBU Geconsolideerd bestaat, zo ja dat die dat eerst delete, en later een nieuwe maakt met de nieuwe data erin. Afgezien van dat werkt de Macro Perfect!

Groetjes,
Phwac

 

[pasan]

Sub Combine2()
    Dim J As Integer
    Dim sh As Worksheet
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  
    On Error GoTo foutje
    
For Each sh In ActiveWorkbook.Sheets
If sh.Name = "Export sBU Geconsolideerd" Then
sh.Delete
End If
Next sh

' Voeg een nieuw blad toe naast het eerste blad
   ThisWorkbook.Sheets.Add After:=Sheets(1)

' Name the new sheet Export sBU Geconsolideerd
    Sheets(2).Name = "Export sBU Geconsolideerd"

'  sheet 3
    Sheets(3).Rows("1").Copy Sheets(2).Rows("1")
   
' work through sheets
    For J = 3 To Sheets.Count ' from sheet 2 to last sheet

     With Sheets(J).Range("A1").CurrentRegion.Offset(1, 0)
        .Copy Sheets(2).Range("B65536").End(xlUp)(2).Offset(, -1)
     End With
     
   Next
   
   With Sheets(2)
   .Columns.AutoFit
   .ListObjects.Add(xlSrcRange, Range("$A$1").CurrentRegion, , xlYes).Name = "Geconsolideerd"
   End With
   
foutje:
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

 

[phwac]

thank you!!

 

[pasan]

graag gedaan en succes
ikzelf stoei nog ff verder met de code van snb en de opmerking over de sheet index nummering

 

[snb]

Sub M_snb()
   on error resume next
   With ThisWorkbook.Sheets.Add(, Sheets(1))
      .Name = "Export sBU Geconsolideerd"
      .usedrange.clearcontents
      .Cells(1).Resize(, Sheets("Blad3").Rows(1).SpecialCells(2).Count) = Sheets("Blad3").Rows(1).SpecialCells(2).Value

      For Each sh In Sheets
        if sh.name<>.name then .Cells(Rows.Count, 2).End(xlUp).Offset(2, -1).Resize(sh.Cells(1).CurrentRegion.Rows.Count, sh.Cells(1).CurrentRegion.Columns.Count) = sh.Cells(1).CurrentRegion.Value
      Next

      .Columns.AutoFit
      .ListObjects.Add(1, .cells(1).CurrentRegion, , xlYes).Name = "Geconsolideerd"
   End With
End Sub