How to create macro to search and copy Closed

Question

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!

venkat1926 · Answer

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

How to create macro to search and copy

1 response

Similar discussions

Subscribe To Our Newsletter!