Find string/date, copy row to another sheet

[Closed]
Report
-
Posts
1862
Registration date
Sunday June 14, 2009
Status
Contributor
Last seen
July 30, 2015
-
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
Related:

7 replies

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

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

Subscribe To Our Newsletter!

The Best of CCM in Your Inbox

Subscribe To Our Newsletter!