Excel - Macro maken om te zoeken en kopiëren

Kwestie

Ik heb een spreadsheet met alle verschillende datums met bijbehorende gegevens in de rij. Er zijn veel rijen met dezelfde datum en ik wil een macro maken om naar alle dezelfde datums te zoeken en ze naar blad 2 kopiëren en plakken, zodat ik ze in volgorde kan plaatsen

voorbeeld:

 27-Sep 27-Sep 27-Sep 28-Sep 28-Sep 01-Oct 01-Oct

Ik heb geen idee hoe ik een macro moet maken, maar ik heb overal op internet gezocht om er een te vinden die ik kon wijzigen om mijn eigen gegevens in te voegen, en dit is wat ik bedacht.

 Sub SearchForString () Dim LSearchRow Als geheel dimmen LCopyToRow Als geheel getal aan fout GoTo Err_Execute 'Zoekopdracht starten in rij 6 LSearchRow = 6' Begin met het kopiëren van gegevens naar rij 110 in Sheet2 (row counter variable) LCopyToRow = 110 While Len (Range ("A") & CStr (LSearchRow)). Waarde)> 0 'Als de waarde in kolom A = "27-Sep" is, kopieert u de gehele rij naar Sheet2 If Range ("A" & CStr (LSearchRow)). Waarde = "27 = Sep" Vervolgens 'Selecteer rij in Blad1 om Rijen te kopiëren (CStr (LSearchRow) & ":" & CStr (LSearchRow)). Selecteer Selectie.Kopiëren' Rij plakken in Blad2 in volgende rij Spreadsheets ("Blad2"). Selecteer Rijen (CStr (LCopyToRow) & ":" & CStr (LCopyToRow)). Selecteer ActiveSheet.Paste 'Verplaats de teller naar de volgende rij LCopyToRow = LCopyToRow + 1' Ga terug naar Sheet1 om door te gaan met zoeken in Sheets ("Sheet1"). Selecteer End If LSearchRow = LSearchRow + 1 Wend 'Positie op cel A109 Application.CutCopyMode = False Range ("A109"). Selecteer MsgBox "Alle overeenkomende gegevens zijn gekopieerd." Exit Sub Err_Execute: MsgBox "Er is een fout opgetreden." End Sub

Oplossing

Ik geef twee macro's "testen" en "ongedaan maken"

het voorbeeldvel is als volgt (sheet1) -niet nodig om te sorteren

datum data1 data2

1-3-2010 37 1

3/2/2010 65 96

3/3/2010 48 46

2/2/2010 78 54

3/5/2010 3 38

3/2/2010 83 58

3/3/2010 45 78

probeer de macro "test" en zie sheet2

als je opnieuw wilt testen

1.run "ongedaan maken"

dan

2.rung "test"

de macro's zijn

 Sub test () Dim r As Range, r1 As Range, r2 As Range Dim c2 As Range, cfind As Range Worksheets ("sheet1"). Activeren Set r = Bereik (Bereik ("A1"), Bereik ("A1") .End (xlDown)) Set r1 = Range ("a1"). End (xlDown) .Offset (5, 0) r.AdvancedFilter action: = xlFilterCopy, copytorange: = r1, unique: = True Set r2 = Range (r1 .Offset (1, 0), r1.End (xlDown)) Voor elke c2 In r2 If WorksFunction.CountIf (r, c2)> 1 Then With Range ("A1"). CurrentRegion .AutoFilter field: = 1, Criteria1: = c2.Value .Cells.SpecialCells (xlCellTypeVisible) .Kopieer-werkbladen ("sheet2"). Cellen (Rows.Count, "A"). Einde (xlUp) .Offset (1, 0) .PasteSpecial End with End If ActiveSheet. AutoFilterMode = False Volgende c2 Werkbladen ("sheet2"). Activeer Do Set cfind = ActiveSheet.Cells.Find (what: = "date", lookat: = xlWhole, after: = Range ("A2")) If cfind Is Nothing Then Exit Do cfind.EntireRow.Delete Loop Worksheets ("sheet1"). Bereik ("A1"). EntireRow.Copy werkbladen ("sheet2"). Bereik ("A1"). PasteSpecial Application.CutCopyMode = False End Sub Sub undo ( ) Werkbladen ("sheet2"). Cellen. Sub eind wissen