Data fra mange ark, skal samles i et ark .. hjælp

Ok prøv denne, sættes i et modul

Lav et nyt ark og navngiv den SamleArk, det er her den gemmer.

koden virker forudsat at der altid er data i kolonne A, når rækken ikke er tom.
Ellers ret kolonne bogstavet i sidste linje.

Public Sub HentArk()
    Dim Ws As Worksheet, data As Variant
    Worksheets("SamleArk").Cells.ClearContents

    For Each Ws In ThisWorkbook.Sheets
        If Ws.Name <> "SamleArk" Then
            data = Ws.Range("A7:H40")
            Worksheets("SamleArk").Range("A65536").End(xlUp).Offset(1, 0).Resize(UBound(data, 1), UBound(data, 2)) = data
        End If
    Next
    Range("A1:A" & Range("A65536").End(xlUp).Row).SpecialCells(xlCellTypeBlanks).EntireRow.Delete Shift:=xlUp
End Sub

Genialt - mange tak

Genialt - tak

;-)) et svar

Kan man gøre noget således at de data der indsættes i samlearket beholder deres formattering. Og kan samlearket tage overskriften A4:H6 fra en af de ark der samles fra. Overskrifterne er ens i alle ark, og altid A6:H6

Public Sub HentArk()
    Dim Ws As Worksheet, data As Variant
    Worksheets("SamleArk").Cells.ClearContents

    For Each Ws In ThisWorkbook.Sheets
        If Ws.Name <> "SamleArk" Then
            Ws.Range("A6:H6").Copy Worksheets("SamleArk").Range("A1")
            Ws.Range("A7:H40").Copy Worksheets("SamleArk").Range("A65536").End(xlUp).Offset(1, 0)
        End If
    Next
    Range("A1:A" & Range("A65536").End(xlUp).Row).SpecialCells(xlCellTypeBlanks).EntireRow.Delete Shift:=xlUp
End Sub

Du er godt nok skarp til det her og det er 99% korrekt - mangler bare at tage celler farver med over i samlearket.
MANGE tak for hjælpen.

den burde tage cellefarver med, men hvis de er der pga. betinget formatering, kommer de ikke med.

Almindelige baggrundsfarve kommer med, er testet.

Mange tak - yes, nu virker det.
Hvis jeg har to Sheets som denne makro ikke skal tage data fra og lægge i samlearket, kan man så gøre noget smart? (sheet navne "overview" & "kunder")

If Ws.Name <> "SamleArk" or Ws.Name <> "overview" or Ws.Name <> "kunder" Then

Hvis koden skal se sådan her ud, så virker det desværre ikke!

Public Sub HentArk()
    Dim Ws As Worksheet, data As Variant
    Worksheets("SamleArk").Cells.ClearContents

    For Each Ws In ThisWorkbook.Sheets
        If Ws.Name <> "SamleArk" or Ws.Name <> "overview" or Ws.Name <> "kunder" Then
            Ws.Range("A6:H6").Copy Worksheets("SamleArk").Range("A1")
            Ws.Range("A7:H40").Copy Worksheets("SamleArk").Range("A65536").End(xlUp).Offset(1, 0)
        End If
    Next
    Range("A1:A" & Range("A65536").End(xlUp).Row).SpecialCells(xlCellTypeBlanks).EntireRow.Delete Shift:=xlUp
End Sub

Overskrifterne i samlearket forsvinder, og der hentes data fra de ark som skulle springes over, og nogle data bliver gengivet i samlearket 2 gange.

Ved ikke hvad der går galt....

sorry, det skulle være And

Public Sub HentArk()
    Dim Ws As Worksheet, data As Variant
    Worksheets("SamleArk").Cells.ClearContents

    For Each Ws In ThisWorkbook.Sheets
        If Ws.Name <> "SamleArk" And Ws.Name <> "overview" And Ws.Name <> "kunder" Then
        Debug.Print Ws.Name
            Ws.Range("A6:H6").Copy Worksheets("SamleArk").Range("A1")
            Ws.Range("A7:H40").Copy Worksheets("SamleArk").Range("A65536").End(xlUp).Offset(1, 0)
        End If
    Next
    Range("A1:A" & Range("A65536").End(xlUp).Row).SpecialCells(xlCellTypeBlanks).EntireRow.Delete Shift:=xlUp
End Sub

fjern lige linjen
Debug.Print Ws.Name

Så sidder den i skabet. Mange mange tak.