Excel - Skapa makro för att söka och kopiera

Problem

Jag har ett kalkylblad med alla olika datum med motsvarande data i raden. Det finns många rader med samma datum och jag vill skapa ett makro för att söka efter alla samma datum och kopiera och klistra in dem till ark 2 så att jag kan placera dem i ordning

exempel:

 27-sep 27-sep 27-sep 28-sep 28-sep 01-okt 01-okt

Jag har ingen aning om hur man skapar ett makro men jag har sökt över hela internet för att hitta en som jag kan ändra för att infoga mina egna data, och det här är vad jag har kommit med.

 Sub SearchForString () Dim LSearchRow som heltal Dim LCopyToRow som heltal på fel GoTo Err_Execute 'Starta sökning i rad 6 LSearchRow = 6' Börja kopiera data till rad 110 i Ark2 (radräknare variabel) LCopyToRow = 110 Medan Len (Range ("A" & CStr (LSearchRow)). Värde)> 0 'Om värdet i kolumn A = "27 sep" kopierar du hela raden till Sheet2 If Range ("A" & CStr (LSearchRow)). Värde = "27 = Sep" Välj rad i Ark1 för att kopiera rader (CStr (LSearchRow) & ":" & CStr (LSearchRow)). Välj Selection.Copy "Klistra in rad i Sheet2 i nästa rad Sheets (" Sheet2 "). Välj rader (CStr (LCopyToRow) & ":" & CStr (LCopyToRow)). Välj ActiveSheet.Paste 'Flytta räknare till nästa rad LCopyToRow = LCopyToRow + 1' Gå tillbaka till Sheet1 för att fortsätta att söka efter Ark ("Sheet1"). Välj Avsluta om LSearchRow = LSearchRow + 1 Wend "Position på cell A109 Application.CutCopyMode = False Range (" A109 "). Välj MsgBox" Alla matchande data har kopierats. " Exit Sub Err_Execute: MsgBox "Ett fel inträffade." Slutdel

Lösning

Jag ger två makron "test" och "ångra"

provarket är så här (sheet1) - inte nödvändigt för att sortera

datumdata1 data2

3/1/2010 37 1

3/2/2010 65 96

3/3/2010 48 46

3/2/2010 78 54

3/5/2010 3 38

3/2/2010 83 58

3/3/2010 45 78

prova makro "test" och se ark2

om du vill ompröva

1.run "ångra"

sedan

2.rung "test"

makronerna är

 Sub-test () Dimma r Som räckvidd, r1 Som räckvidd, r2 Som räckvidd Dim c2 Som Räckvidd, se som Räckvidd ("Sheet1"). Aktivera Set r = Räckvidd (Räckvidd ("A1"), Räckvidd ("A1") .End (xlDown)) Ange r1 = Räckvidd ("a1"). Slut (xlDown) .Offset (5, 0) r.AdvancedFilter-åtgärd: = xlFilterCopy, copytorange: = r1, unik: = True Set r2 = Räckvidd .Offset (1, 0), r1.End (xlDown)) För varje c2 I r2 Om ArbetsbladFunktion.CountIf (r, c2)> 1 Sedan Med Räckvidd ("A1") .RiktigtRegion .AutoFilterfält: = 1, Kriterier1: = c2.Value .Cells.SpecialCells (xlCellTypeVisible) .Copy Worksheets ("sheet2"). Celler (Rows.Count, "A"). Slut (xlUp) .Offset (1, 0) .PasteSpecial End With End Om ActiveSheet. AutoFilterMode = False Next c2 Arbetsblad ("sheet2"). Aktivera Gör cfind = ActiveSheet.Cells.Find (what: = "date", lookat: = xlWhole efter: = Område ("A2")) Om cfind är ingenting då Avsluta Gör cfind.EntireRow.Delete Loop Worksheets ("sheet1"). Räckvidd ("A1") .HelaRow.Copy-kalkylblad ("ark2"). Räckvidd ("A1"). PasteSpecial Application.CutCopyMode = Felaktigt subunderlag ångra ) Arbetsblad ("ark2"). Celler. Klar slutdel