VBA kode til søge i ark og flytte data

Har du overvejet i stedet at benytte "Konsolider" funktionaliteten som findes under Fanen "Data"?

Hvis du bliver lidt mere konkret kan jeg (og andre) sikkert hjælpe. Hvor er det præcist det går i stå for dig?

Jeg har en excel fil med, 16 ark, hver ark er knyttet til en anden excel fil hvor fra den henter data via query, Nå det har hentet data
er hver ark en afdeling, hver række i kolonne A er Uge nummer og datoer imellem, kolonne B er total tid for ugen og tid for hver dato.
Jeg har optaget en makro som sortere uger, bagefter kopere den ugerne fra hver ark og samler dem på ark 17 (som en form for et rapport) Men der er ikke altid de samme antal uger. Derfor var nemmest løsning at jeg har bare lavet mellemrum så den går og kopiere data og indsætter dem hver gang 53 rækker under hinanden.
Men der er ikke altid der er alle 52 uger for hver afdeling, det kan også være bare 2 uger så kommer det til at se dumt ud, så kommer data fra ark 1 og så er der 51 rækker tomme bagefter kommer data fra ark 2 osv osv. Kan man ikke få makroen til at den selv finder ud af hvor meget data den har hentet fra ark1 så nå den kopere data over fra ark 2 at der er data fra ark 1 plus en tom række og så kommer data fra ark2 osv.

et forslag

Option Explicit
Option Base 1


Public Sub samleark()

    Dim RåData As Variant, UdData As Variant, WS As Variant
    Dim UD As Long, Tekst As String
    Dim I As Integer, J As Long, X As Integer, Kol As Integer, Rk As Long, Y As Integer
    WS = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16)    ' dataark hvorfra der hentes
    UD = 1
    Tekst = "hej"    ' tekst der skal findes i arkene kolonne A' ret til dit søgeord

    For Y = 1 To UBound(WS)
        RåData = Sheets(WS(I)).Range("A2:E" & Sheets(WS(I)).Range("A65536").End(xlUp).Row)    ' finder dataområdet
        Rk = UBound(RåData, 1)    ' hvor mange rækker
        Kol = UBound(RåData, 2)  ' hvor mange kolonner

        ReDim UdData(Rk, Kol)    ' redim uddata,så der er plads til alle

        For J = 2 To Rk
            If InStr(1, UCase(RåData(J, 1)), Tekst) > 0 Then ' finder søgeordet
                For X = 1 To Kol
                    UdData(UD, X) = RåData(J, X) ' skriver det fundne i uddata
                Next
                UD = UD + 1 ' ny række til uddata
            End If
        Next
        If WS(I) = 1 Then
            Sheets(17).Range("A2").Resize(Rk, Kol) = UdData    ' første gang der gemmes fra ark 1
        Else
            'resten af arkene med en rækkes mellemrum
            Sheets(17).Range("A" & Sheets(17).).Range("A65536").End(xlUp).Row + 2).Resize(Rk, Kol) = UdData
        End If
    Next
End Sub

NB tøm ark 17 før du køre makroen, men behold overskrifterne.

Hej jeg har først set koden nu prøver lige og kikke på den.

Jeg har ikke kunne få den til at virke, der er heller ikke nogen overskrifter, jeg har lavet min makro sådan at den går ind på hver ark sortere kolonne f med at den ikke viser 0 (så vil den kun vise rækker med uger) bagefter går den op søg efter -> aktuel område, copy og paste til ark 17, det gøre den med alle 16 ark. Men det bliver som enkelt data uden tabeller, kunne ikke finde ud af det på andet måde.

Prøv at vis din kode

Sub Flyttedata()
'
' Flyttedata Makro
'
' Genvejstast:Ctrl+a
'
    ActiveSheet.ListObjects("Tabel_EksterneData_117").Range.AutoFilter Field:=6, _
        Criteria1:=Array("09", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19"), _
        Operator:=xlFilterValues
    Selection.CurrentRegion.Select
    Selection.Copy
    ActiveWindow.ScrollWorkbookTabs Position:=xlLast
    Sheets("Rapport").Select
    ActiveWindow.SmallScroll Down:=-18
    Range("A1").Select
    ActiveSheet.Paste
    Columns("A:A").ColumnWidth = 24.14
    Columns("B:B").ColumnWidth = 20.86
    Columns("C:C").ColumnWidth = 12.71
    Columns("C:C").ColumnWidth = 17
    Columns("C:C").ColumnWidth = 15.71
    Columns("C:C").ColumnWidth = 14.57
    ActiveWindow.SmallScroll Down:=21
    ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
    Sheets("Afdeling1").Select
    ActiveSheet.ListObjects("Tabel_Forespørgsel_fra_Excel_Files3").Range. _
        AutoFilter Field:=6, Criteria1:=Array("09", "10", "11", "12", "13", "14", "15", _
        "16", "17", "18", "19"), Operator:=xlFilterValues
    Selection.CurrentRegion.Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveWindow.ScrollWorkbookTabs Position:=xlLast
    Sheets("Rapport").Select
    Range("A54").Select
    ActiveSheet.Paste
    ActiveWindow.SmallScroll Down:=39
    ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
    Sheets("Afdeling2").Select
    ActiveSheet.ListObjects("Tabel_Forespørgsel_fra_Excel_Files4").Range. _
        AutoFilter Field:=6, Criteria1:=Array("09", "10", "11", "12", "13", "14", "15", _
        "16", "17", "18", "19"), Operator:=xlFilterValues
    Selection.CurrentRegion.Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveWindow.ScrollWorkbookTabs Position:=xlLast
    Sheets("Rapport").Select
    ActiveWindow.SmallScroll Down:=15
    Range("A105").Select
    ActiveSheet.Paste
    ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
    Sheets("Afdeling3").Select
    ActiveSheet.ListObjects("Tabel_TEST").Range.AutoFilter Field:=6, Criteria1 _
        :=Array("09", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19"), Operator:= _
        xlFilterValues
    Selection.CurrentRegion.Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveWindow.ScrollWorkbookTabs Position:=xlLast
    Sheets("Rapport").Select
    ActiveWindow.SmallScroll Down:=51
    Range("A155").Select
    ActiveSheet.Paste
    ActiveWindow.SmallScroll Down:=12
    ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
    Sheets("Afdeling4").Select
    ActiveSheet.ListObjects("Tabel_EksterneData_1").Range.AutoFilter Field:=6, _
        Criteria1:=Array("09", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19"), _
        Operator:=xlFilterValues
    Selection.CurrentRegion.Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveWindow.ScrollWorkbookTabs Position:=xlLast
    Sheets("Rapport").Select
    ActiveWindow.SmallScroll Down:=39
    Range("A204").Select
    ActiveSheet.Paste
    ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
    Sheets("Afdeling5").Select
    ActiveSheet.ListObjects("Tabel_EksterneData_17").Range.AutoFilter Field:=6, _
        Criteria1:=Array("09", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19"), _
        Operator:=xlFilterValues
    Selection.CurrentRegion.Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveWindow.ScrollWorkbookTabs Position:=xlLast
    Sheets("Rapport").Select
    ActiveWindow.SmallScroll Down:=48
    Range("A252").Select
    ActiveSheet.Paste
    ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
    Sheets("Afdeling6").Select
    ActiveSheet.ListObjects("Tabel_EksterneData_18").Range.AutoFilter Field:=6, _
        Criteria1:=Array("09", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19"), _
        Operator:=xlFilterValues
    Selection.CurrentRegion.Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveWindow.ScrollWorkbookTabs Position:=xlLast
    Sheets("Rapport").Select
    ActiveWindow.SmallScroll Down:=54
    Range("A305").Select
    ActiveSheet.Paste
    ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
    Sheets("Afdeling7").Select
    ActiveSheet.ListObjects("Tabel_EksterneData_19").Range.AutoFilter Field:=6, _
        Criteria1:=Array("09", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19"), _
        Operator:=xlFilterValues
    Selection.CurrentRegion.Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveWindow.ScrollWorkbookTabs Position:=xlLast
    Sheets("Rapport").Select
    ActiveWindow.SmallScroll Down:=54
    Range("A355").Select
    ActiveSheet.Paste
    Sheets("Afdeling8").Select
    ActiveSheet.ListObjects("Tabel_EksterneData_110").Range.AutoFilter Field:=6, _
        Criteria1:=Array("09", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19"), _
        Operator:=xlFilterValues
    Selection.CurrentRegion.Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveWindow.ScrollWorkbookTabs Position:=xlLast
    Sheets("Rapport").Select
    ActiveWindow.SmallScroll Down:=45
    Range("A404").Select
    ActiveSheet.Paste
    ActiveWindow.SmallScroll Down:=36
    Sheets("Afdeling9").Select
    ActiveSheet.ListObjects("Tabel_EksterneData_111").Range.AutoFilter Field:=6, _
        Criteria1:=Array("09", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19"), _
        Operator:=xlFilterValues
    Application.CutCopyMode = False
    Selection.Copy
    Selection.CurrentRegion.Select
    Sheets("Rapport").Select
    ActiveWindow.SmallScroll Down:=60
    Range("A500").Select
    ActiveSheet.Paste
    Sheets("Afdeling10").Select
    ActiveSheet.ListObjects("Tabel_EksterneData_112").Range.AutoFilter Field:=6, _
        Criteria1:=Array("09", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19"), _
        Operator:=xlFilterValues
    Selection.CurrentRegion.Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Rapport").Select
    ActiveWindow.SmallScroll Down:=63
    Range("A552").Select
    ActiveSheet.Paste
    Sheets("Afdeling11").Select
    ActiveSheet.ListObjects("Tabel_EksterneData_113").Range.AutoFilter Field:=6, _
        Criteria1:=Array("09", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19"), _
        Operator:=xlFilterValues
    Selection.CurrentRegion.Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Rapport").Select
    ActiveWindow.SmallScroll Down:=39
    Range("A604").Select
    ActiveSheet.Paste
    Sheets("Afdeling12").Select
    ActiveSheet.ListObjects("Tabel_EksterneData_114").Range.AutoFilter Field:=6, _
        Criteria1:=Array("09", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19"), _
        Operator:=xlFilterValues
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Rapport").Select
    ActiveWindow.SmallScroll Down:=51
    Range("A652").Select
    ActiveSheet.Paste
    ActiveWindow.SmallScroll Down:=27
    Sheets("Afdeling13").Select
    ActiveSheet.ListObjects("Tabel_EksterneData_115").Range.AutoFilter Field:=6, _
        Criteria1:=Array("09", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19"), _
        Operator:=xlFilterValues
    Selection.CurrentRegion.Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveWindow.SmallScroll Down:=3
    Sheets("Rapport").Select
    Range("A678:B678").Select
    Range("B678").Activate
    ActiveWindow.SmallScroll Down:=18
    Range("A702").Select
    ActiveSheet.Paste
    ActiveWindow.SmallScroll Down:=27
    Sheets("Afdeling14").Select
    ActiveSheet.ListObjects("Tabel_EksterneData_116").Range.AutoFilter Field:=6, _
        Criteria1:=Array("09", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19"), _
        Operator:=xlFilterValues
    Application.CutCopyMode = False
    Selection.Copy
    Selection.CurrentRegion.Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Rapport").Select
    ActiveWindow.SmallScroll Down:=30
    Range("A754").Select
    ActiveSheet.Paste
    ActiveWindow.SmallScroll Down:=-114
    ActiveWindow.ScrollRow = 614
    ActiveWindow.ScrollRow = 608
    ActiveWindow.ScrollRow = 604
    ActiveWindow.ScrollRow = 597
    ActiveWindow.ScrollRow = 587
    ActiveWindow.ScrollRow = 574
    ActiveWindow.ScrollRow = 562
    ActiveWindow.ScrollRow = 549
    ActiveWindow.ScrollRow = 534
    ActiveWindow.ScrollRow = 520
    ActiveWindow.ScrollRow = 502
    ActiveWindow.ScrollRow = 488
    ActiveWindow.ScrollRow = 472
    ActiveWindow.ScrollRow = 458
    ActiveWindow.ScrollRow = 444
    ActiveWindow.ScrollRow = 431
    ActiveWindow.ScrollRow = 419
    ActiveWindow.ScrollRow = 405
    ActiveWindow.ScrollRow = 393
    ActiveWindow.ScrollRow = 377
    ActiveWindow.ScrollRow = 365
    ActiveWindow.ScrollRow = 350
    ActiveWindow.ScrollRow = 338
    ActiveWindow.ScrollRow = 325
    ActiveWindow.ScrollRow = 312
    ActiveWindow.ScrollRow = 301
    ActiveWindow.ScrollRow = 291
    ActiveWindow.ScrollRow = 284
    ActiveWindow.ScrollRow = 276
    ActiveWindow.ScrollRow = 271
    ActiveWindow.ScrollRow = 264
    ActiveWindow.ScrollRow = 259
    ActiveWindow.ScrollRow = 254
    ActiveWindow.ScrollRow = 250
    ActiveWindow.ScrollRow = 246
    ActiveWindow.ScrollRow = 240
    ActiveWindow.ScrollRow = 236
    ActiveWindow.ScrollRow = 232
    ActiveWindow.ScrollRow = 225
    ActiveWindow.ScrollRow = 220
    ActiveWindow.ScrollRow = 213
    ActiveWindow.ScrollRow = 206
    ActiveWindow.ScrollRow = 198
    ActiveWindow.ScrollRow = 190
    ActiveWindow.ScrollRow = 184
    ActiveWindow.ScrollRow = 175
    ActiveWindow.ScrollRow = 167
    ActiveWindow.ScrollRow = 160
    ActiveWindow.ScrollRow = 151
    ActiveWindow.ScrollRow = 143
    ActiveWindow.ScrollRow = 136
    ActiveWindow.ScrollRow = 130
    ActiveWindow.ScrollRow = 123
    ActiveWindow.ScrollRow = 119
    ActiveWindow.ScrollRow = 113
    ActiveWindow.ScrollRow = 109
    ActiveWindow.ScrollRow = 106
    ActiveWindow.ScrollRow = 105
    ActiveWindow.ScrollRow = 102
    ActiveWindow.ScrollRow = 101
    ActiveWindow.ScrollRow = 100
    ActiveWindow.ScrollRow = 98
    ActiveWindow.ScrollRow = 95
    ActiveWindow.ScrollRow = 93
    ActiveWindow.ScrollRow = 91
    ActiveWindow.ScrollRow = 88
    ActiveWindow.ScrollRow = 87
    ActiveWindow.ScrollRow = 86
    ActiveWindow.ScrollRow = 84
    ActiveWindow.ScrollRow = 83
    ActiveWindow.ScrollRow = 80
    ActiveWindow.ScrollRow = 77
    ActiveWindow.ScrollRow = 72
    ActiveWindow.ScrollRow = 69
    ActiveWindow.ScrollRow = 63
    ActiveWindow.ScrollRow = 58
    ActiveWindow.ScrollRow = 55
    ActiveWindow.ScrollRow = 50
    ActiveWindow.ScrollRow = 46
    ActiveWindow.ScrollRow = 43
    ActiveWindow.ScrollRow = 39
    ActiveWindow.ScrollRow = 38
    ActiveWindow.ScrollRow = 36
    ActiveWindow.ScrollRow = 35
    ActiveWindow.ScrollRow = 32
    ActiveWindow.ScrollRow = 31
    ActiveWindow.ScrollRow = 30
    ActiveWindow.ScrollRow = 29
    ActiveWindow.ScrollRow = 28
    ActiveWindow.ScrollRow = 27
    ActiveWindow.ScrollRow = 25
    ActiveWindow.ScrollRow = 23
    ActiveWindow.ScrollRow = 21
    ActiveWindow.ScrollRow = 20
    ActiveWindow.ScrollRow = 17
    ActiveWindow.ScrollRow = 14
    ActiveWindow.ScrollRow = 11
    ActiveWindow.ScrollRow = 9
    ActiveWindow.ScrollRow = 8
    ActiveWindow.ScrollRow = 7
    ActiveWindow.ScrollRow = 6
    ActiveWindow.ScrollRow = 4
    ActiveWindow.ScrollRow = 2
    ActiveWindow.ScrollRow = 1
    Columns("F:F").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
End Sub

Koden sortere data i tabellen kopiere det over fra arkene til ark 17, men eftersom det kan variere fra 1 uge til 52 så er der en tilfældig antal tomme rækker imellem på ark 17 for at der er plads til i tilfælde der er i alt 52 uger i stedet for 9 til 19 som vist i koden  ovenover. derfor mangler jeg en kode så den selv kan flytte data op il hinanden med 1 række medlemrum

afslutter dette tråd pga manglende svar