Excel - Creating macro to search and copy

February 2017




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


Published by aakai1056. Latest update on March 21, 2010 at 03:53 PM by aakai1056.
This document, titled "Excel - Creating macro to search and copy," is available under the Creative Commons license. Any copy, reuse, or modification of the content should be sufficiently credited to CCM (ccm.net).