Find string/date, copy row to another sheet Closed

Question

Hello, 

I'm new to VBA and currently working on a macro wherein I wanted to search for a specific date (e.g. 08/17/2010) then copy the entire row from that sheet to another one.

I'm currently using 5 sheets - "OverAll" which contains the summary, the other 4 sheets would be named as Ces, Karlo, Emman and Vidya.

This is what I have worked out so far starting with the first sheet, Ces.


Sub CopyOverall()

    Dim CurrentDate As Date
        CurrentDate = Date
        
    CurrentDate = InputBox("Input Date as MM/DD/YYYY):")
    
    Dim LSearchRow As String
    Dim LCopyToRow As String

        On Error GoTo Err_Execute

        'Start search in row 2
        Sheets("Ces").Select
        LSearchRow = 2

        'Start copying data to row 2 in Ces (row counter variable)
        LCopyToRow = 2

        While Len(Range("A" & CStr(LSearchRow)).Date) > 0
        
            'Go to Ces worksheet
            Sheets("Ces").Select

            'If Date in column A = CurrentDate, copy entire row to Sheet2
            If Range("A" & CStr(LSearchRow)).Date = CurrentDate Then _
                         
                'Select row in Ces to copy
                Sheets("Ces").Select
                Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
                Selection.Copy

                'Paste row into OverAll in next row
                Sheets("OverAll").Select
                Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
                ActiveSheet.Paste

                'Move counter to next row
                LCopyToRow = LCopyToRow + 1

                'Go back to Ces to continue searching
                Sheets("Ces").Select

            End If

            LSearchRow = LSearchRow + 1

        Wend

        'Position on cell A3
        Application.CutCopyMode = False
        Range("A3").Select

        MsgBox "All matching data has been copied."


Err_Execute:
        MsgBox "An error occurred."
End Sub 



Would appreciate any inputs on this as I'm new to VBA. Thanks! -Karlo
Configuration: Windows 7 / Firefox 3.6.8

venkat1926 · Answer

I personally find it difficult to correct a long macro as I have to sync with the creator of the macro.  I also presume there is only one date (that is today's date). in each sheet and there is no such date. also remember here today is 18 August 


if there are more than one todays date the macro has to be mdofied. 


do you think the following macro will get what you want?

===============

Sub test()
Dim j As Integer, k As Integer, cfind As Range, dest As Range
j = Worksheets.Count
For k = 1 To j
    If Worksheets(k).Name = "Overall" Then GoTo nextk
    'NAME OF SHEET SHOULD EXACT INCLUDING CASE
    With Worksheets(k)
    Set cfind = .Cells.Find(what:=CDate(Date), lookat:=xlWhole)
    If cfind Is Nothing Then GoTo nextk
    cfind.EntireRow.Copy
    With Worksheets("Overall")
        Set dest = .Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
        dest.PasteSpecial
        End With
nextk:
End With
Next k
End Sub

============================

Karlo · Answer

Hi  venkat1926,


Thank you for your prompt reply. 

I'm trying to create a macro wherein it asks the user to input a date. (created an InputBox for this)

It will then look for that date in all the succeeding sheets then copy the entire row from those sheets to the OverAll sheet.

The macro you inputted runs but you are right, the search has to be based on the date inputted on the InputBox and not just today's date.

 Do you think you could modify the macro you inputted? It would greatly appreciated. 


Thanks!
Karlo

venkat1926 · Answer

try this macro


Sub test()
Dim j As Integer, k As Integer, cfind As Range, dest As Range
Dim d As Date
d = InputBox("type date you require in format mm/d/y")
j = Worksheets.Count
For k = 1 To j
If Worksheets(k).Name = "Overall" Then GoTo nextk
'NAME OF SHEET SHOULD EXACT INCLUDING CASE
With Worksheets(k)
Set cfind = .Cells.Find(what:=CDate(d), lookat:=xlWhole)
If cfind Is Nothing Then GoTo nextk
cfind.EntireRow.Copy
With Worksheets("Overall")
Set dest = .Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
dest.PasteSpecial
End With
nextk:
End With
Next k
End Sub

Karlo · Answer

Hi venkat1926,

It works except it copies/pastes only the first item it captures on each succeeding worksheet. 

Let's say if there were 4 succeeding worksheets with each sheet having about a dozen rows having the date e.g. 08/21/2010. 

The macro would capture/paste only the first 08/21/2010 it sees on the first sheet, only the first 08/21/2010 it sees on the 2nd sheet, only the first 08/21/2010 on the 3rd sheet and so forth.

We need to capture/paste every row that has the date e.g. 08/21/2010 on each sheet, not just the first 08/21/2010 it sees on each sheet.



We've tried this macro -



Sub CopyOverAll()

Dim CurrentDate As Date
Dim j As Integer
Dim ws As Worksheet
Dim I As Double
Dim douTotal As Double
Dim cfind As Range
Dim dest As Range
    CurrentDate = Date
    CurrentDate = InputBox("Input Date as MM/DD/YYYY:")
'    If Len(CurrentDate) = 0 Then Exit Sub

    j = Worksheets.Count
    
    For Each ws In Worksheets
    I = 2
    If ws.Name = "OverAll" Then
        GoTo nextk:
    Else
        
        douTotal = Application.WorksheetFunction.CountA(ws.Range("A:A"))
       
        Do While I < douTotal + 1
            ws.Select
            If Cells(i, 1) = CurrentDate Then
                Rows(i).Copy
                Sheets("OverAll").Select
                Range("A" & Application.WorksheetFunction.CountA(Range("A:A")) + 3).Select
                Selection.PasteSpecial Paste:=xlPasteValues
                Application.CutCopyMode = False
            End If
            I = I + 1
            
        Loop
    End If
nextk:

Next

End Sub


..and it works but it's too long. Is there anyway that yours can be tweaked to come up with the same result? Many thanks!

venkat1926 · Answer

I indicated the need for modification. You can use eiher findnext code or autofitler. 
try this macro and give your comments 
TEH DATES ARE IN COLUMN A OF EACH OF THE SHEETS

Sub test() 
Dim r As Range, rfilt As Range 
Dim j As Integer, k As Integer, dest As Range 
Dim d As Date 
Worksheets("Overall").Cells.Clear 
d = InputBox("type date you require in format mm/d/y") 
j = Worksheets.Count 
For k = 1 To j 
If Worksheets(k).Name = "Overall" Then GoTo nextk 
'NAME OF SHEET SHOULD EXACT INCLUDING CASE 
With Worksheets(k) 
Set r = .Range("A1").CurrentRegion 
If WorksheetFunction.CountIf(r, d) = 0 Then GoTo nextk 
r.AutoFilter field:=1, Criteria1:=d 
Set rfilt = r.Offset(1, 0) 
'msgbox rfilt.Address 
rfilt.Cells.SpecialCells(xlCellTypeVisible).Copy 
With Worksheets("Overall") 
Set dest = .Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) 
dest.PasteSpecial 
End With 
r.AutoFilter 
End With 
nextk: 
Next k 
Worksheets("Ces").Range("A1").EntireRow.Copy 
Worksheets("Overall").Range("A1").PasteSpecial 
End Sub

Karlo · Answer

Hi venkat1926,

The headers for each worksheet seem to get copied together with the filtered date/rows that are being copied.

When the rows are pasted to the OverAll summary sheet, the headers from the succeeding sheets get pasted as well.

Would there be a remedy for this?


Thanks!
Karlo

venkat1926 · Answer

I do not know how your sheets are configured. do they have different headings for different sheets?  I am sending my sample workbook. download from this web page and if possible and necessary modify the macro. If you still have problem post a very small extract of your file in speedyshare.com(as I have done) and explain once again with examples. The macro is in module in vb editor.

http://www.speedyshare.com/files/23938925/karlo2.xls

in the workbook you see sheet "overall" AFTER  running the macro 
"test"
if you want you can again run the macro and check.

Find string/date, copy row to another sheet

7 responses

Similar discussions

Subscribe To Our Newsletter!