VBA code voor het copy pasten van data van Tab X naar tab Y

[nente002]

Hallo, Ik ben bezig met een macro om data van de ene tab naar de andere tab te copy/pasten als een kolom in de eerste tab een bepaalde waarde heeft.
Maar kom niet verder dan het copy/pasten van de headers.

In mijn sheet heb ik een tab "Import data" in die tab bevat kolom "D" een waarde waarop ik wil selecteren en vervolgens die regel naar het corresponderende tab kopieren.
Dus Als "D" in "Import data" COM02 bevat de hele regel naar tab blad "COM02" kopieren enz..
Dit voor alle regels uit "Import data"
De sheet is te groot om aan dit bericht te hangen.. dus als je die wil zien:
http://www.MegaShare.com/3517470

Hopelijk kan iemand me helpen!
Dit is de code die ik gebruik maar deze code kopieert alleen de headers... en niet de onderliggende data:

Sub ExtractData()
    Dim lr As Long
    Dim i As Long
    
    mysheet = Array("COM02", "COM04", "COM05")
    lr = Sheets("Import data").Range("C" & Rows.Count).End(xlUp).Row
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    For i = 0 To UBound(mysheet)
        Sheets(mysheet(i)).UsedRange.ClearContents
        With Sheets("Import data").Range("A1:L" & lr)
            .AutoFilter Field:=3, Criteria1:=mysheet(i)
            .Copy Destination:=Sheets(mysheet(i)).Range("A1")
            .AutoFilter
        End With
    Next i
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

 

[geep1980]

probeer het eens met de volgende macro.

Deze komt met een popup waar je de Action Type Code die je wil copieren in kan vullen.
Daarna loopt hij alle rijen in Import Data af en copieerd ze naar de juiste Tab

Sub test()


strName = InputBox(Prompt:="Which Action Type Code.", _
          Title:="Which Action Type Code", Default:="Which Action Type Code")

rNa = strName

Sheets("Import Data").Select

    Dim LSearchRow As Integer
    Dim LCopyToRow As Integer

     On Error GoTo Err_Execute

    'Start search in row 2
    LSearchRow = 2

    'Start copying data to row 2 in Sheet2 (row counter variable)
    LCopyToRow = 2

    While Len(Range("D" & CStr(LSearchRow)).Value) > 0

        'If value in column E = "Mail Box", copy entire row to Sheet2
        If Range("D" & CStr(LSearchRow)).Value = rNa Then

            'Select row in Sheet1 to copy
            Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
            Selection.Copy

            'Paste row into Sheet2 in next row
            Sheets(strName).Select
            
            Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
            ActiveSheet.Paste

            'Move counter to next row
            LCopyToRow = LCopyToRow + 1

  

            'Go back to Sheet1 to continue searching
            Sheets("Import Data").Select

        End If

        LSearchRow = LSearchRow + 1
  

    Wend
    Exit Sub

Err_Execute:
    
    MsgBox "An error occurred."

End Sub

 

[nente002]

Hartelijk dank geep1980,
Ik ga het morgen proberen!
Maar het zou fijn zijn als het zonder box kan omdat het om 36 action types gaat
Die allemaal op hun eigen tab moeten komen...

 

[geep1980]

Je kan zelf een macro maken door kolom D naar een apart blad te copieeren als unieke waarde.
dan kan je daarna een do loop creeeren om alles wat in het aparte blad staat te gebruiken als invoer waardes.

Ik zal morgen kijken om het te maken.

Ik weet niet of de waardes elke aangevuld moeten worden of dat je elke keer nieuwe waardes hebt.
Anders kan je de tabbladen weg gooien en opnieuw aan laten maken.

 

[Warme bakkertje]

.AutoFilter Field:=[COLOR="red"]4[/COLOR], Criteria1:=mysheet(i)

 

[nente002]

Bedankt!!

Heren! Bedankt voor jullie hulp! Wat werken forums toch heerlijk!
Zoals ik zeg ik zal jullie oplossingen morgen proberen.
Groet!

 

[geep1980]

Hierbij drie macro

Er wordt een sheet Help gemaakt en weg gegooid waarop tijdelijk de verschillende Action Type Codes komen te staan.
Deze worden unique gefilterd in het sheet Waar op splitsen geplaatst.

Vanuit deze sheet worden er per Action Type Code een nieuwe sheet aangemaakt waarop alle waardes worden gecopieerd.

Sub Filter_Import_Data()
'
Call Delete_Sheets
Call Splitsen_Unique_Waardes

splits_waarde = 1

Do While splits_waarde < Application.CountIf(Worksheets("Waar op splitsen").Range("A:A"), ">""") + 1
Set waarde = Worksheets("Waar op splitsen").Range("A" & splits_waarde)

Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = waarde
    On Error GoTo next1
    Sourcesheet = ActiveSheet.Name
    
    Sheets("Import data").Select
    Range("A1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$I$25887").AutoFilter Field:=4, Criteria1:=waarde
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    
    Selection.Copy
    
    Sheets(Sourcesheet).Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=True, Transpose:=False
    Cells.Select
    Cells.EntireColumn.AutoFit
    Range("A1").Select
    Application.CutCopyMode = False
    
    Sheets("Import data").Select
    Range("A1").Select
    ActiveSheet.ShowAllData
    Selection.AutoFilter
    
    
next1:
    
splits_waarde = splits_waarde + 1

Loop
 
End Sub
Sub Splitsen_Unique_Waardes()
'
Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = "Help"
Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = "Waar op splitsen"

    Sheets("Import data").Select
    Columns("D:D").Select
    Selection.Copy
    Sheets("Help").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Rows("1:1").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    
    LastRow = Application.CountIf(Worksheets("Help").Range("A:A"), ">""")
    Range("$A$1:$A$" & LastRow).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    
    Range("$A$1:$A$" & LastRow).Select
    Selection.Copy
    
    Sheets("Waar op splitsen").Select
    Range("$A$1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        True, Transpose:=False
    
    Application.CutCopyMode = False
  
    Application.DisplayAlerts = False
        Sheets("Help").Delete
    Application.DisplayAlerts = True
  
End Sub
Sub Delete_Sheets()

Application.DisplayAlerts = False
Dim sh As Worksheet
 For Each sh In ActiveWorkbook.Worksheets
 If sh.Name <> "InfoBlad" And sh.Name <> "Reken Blad" And sh.Name <> "Deadline momenten" And sh.Name <> "Import data" Then
 sh.Delete
 End If
 Next sh
 Application.DisplayAlerts = True

End Sub