How to create macro to search and copy [Closed]

Report
Posts
1
Registration date
Saturday March 20, 2010
Status
Member
Last seen
March 20, 2010
-
Posts
1862
Registration date
Sunday June 14, 2009
Status
Contributor
Last seen
July 30, 2015
-
Hello,
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

Please HELP!!! im desperate

Thanks in advance to whomever can save mee!

1 reply

Posts
1862
Registration date
Sunday June 14, 2009
Status
Contributor
Last seen
July 30, 2015
797
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

Subscribe To Our Newsletter!

The Best of CCM in Your Inbox

Subscribe To Our Newsletter!