Excel - Creating macro to search and copy

December 2016




Issue


I have a spreadsheet with all different dates with corresponding data in its row. There are many rows with the same date and i want to create a macro to search for all the same dates and copy and paste them to sheet 2 so i can put them in order

example:

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


I have no idea how to create a macro however i have searched all over the internet to find one that i could modify to insert my own data, and this is what ive come up with.

Sub SearchForString() 

Dim LSearchRow As Integer 
Dim LCopyToRow As Integer 

On Error GoTo Err_Execute 

'Start search in row 6 
LSearchRow = 6 

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

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

'If value in column A = "27-Sep", copy entire row to Sheet2 
If Range("A" & CStr(LSearchRow)).Value = "27=Sep" Then 

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

'Paste row into Sheet2 in next row 
Sheets("Sheet2").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("Sheet1").Select 

End If 

LSearchRow = LSearchRow + 1 

Wend 

'Position on cell A109 
Application.CutCopyMode = False 
Range("A109").Select 

MsgBox "All matching data has been copied." 

Exit Sub 

Err_Execute: 
MsgBox "An error occurred." 

End Sub 

Solution


I am giving two macros "test" and "undo"

the sample sheet is like this (sheet1)-not necessary to sort
date data1 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

try the macro "test" and see sheet2

if you want retest
1.run "undo"
then
2.rung "test"

the macros are


Sub test()
Dim r As Range, r1 As Range, r2 As Range
Dim c2 As Range, cfind As Range
Worksheets("sheet1").Activate
Set r = Range(Range("A1"), Range("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))
For Each c2 In r2
If WorksheetFunction.CountIf(r, c2) > 1 Then
With Range("A1").CurrentRegion
.AutoFilter field:=1, Criteria1:=c2.Value
.Cells.SpecialCells(xlCellTypeVisible).Copy
Worksheets("sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial
End With
End If
ActiveSheet.AutoFilterMode = False
Next c2
Worksheets("sheet2").Activate
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").Range("A1").EntireRow.Copy
Worksheets("sheet2").Range("A1").PasteSpecial
Application.CutCopyMode = False
End Sub



Sub undo()
Worksheets("sheet2").Cells.Clear
End Sub

Note


Thanks to venkat1926 for this tip on the forum.

Related :

This document entitled « Excel - Creating macro to search and copy » from CCM (ccm.net) is made available under the Creative Commons license. You can copy, modify copies of this page, under the conditions stipulated by the license, as this note appears clearly.