Find All, Copy Adjacent Cells, Paste in New Window

[DEMI224]

I need to separate numerous data entries by year, so I need to find all entries containing the year in question, copy the cell year is listed in as well as 2 cells on either side, and paste the 5 cells into a new spreadsheet. Here's the code I have closest to working:

Cells.Find(What:="2000", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, _
SearchFormat:=False).Activate
ActiveCell.Offset(0, -2).Resize(1, 5).Copy
Sheets.Add After:=Sheets("2000")
ActiveSheet.Paste
Worksheets("Sheet1").Activate

This finds the first case, but I'm having trouble constructing a loop that will do this (particularly the offset) for all found values. There are dates in multiple columns, so I can't just copy the entire row, either.

 

[JLGWhiz]

I need to separate numerous data entries by year, so I need to find all entries containing the year in question, copy the cell year is listed in as well as 2 cells on either side, and paste the 5 cells into a new spreadsheet. Here's the code I have closest to working:

Cells.Find(What:="2000", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, _
SearchFormat:=False).Activate
ActiveCell.Offset(0, -2).Resize(1, 5).Copy
Sheets.Add After:=Sheets("2000")
ActiveSheet.Paste
Worksheets("Sheet1").Activate

This finds the first case, but I'm having trouble constructing a loop that will do this (particularly the offset) for all found values. There are dates in multiple columns, so I can't just copy the entire row, either.

This assumes that you want to create a new worksheet for each successful find. It also assumes that the data to find is a series of years, and in the code these are assigned to the (i) variable. The number of years used was arbitrary and will need to be reviewed and revised, or if the assumption was incorrect then a completely different set of values or a different method of searching will need to be used. But the code provides a loop and will paste the found data into each new worksheet.

Code:
Sub fnd()
Dim c As Range, newSh As Worksheet
For i = 2000 To 2012
Set c = ActiveSheet.Cells.Find(What:=i, After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, _
SearchFormat:=False)
If Not c Is Nothing Then
c.Offset(0, -2).Resize(1, 5).Copy
Set newSh = Sheets.Add(After:=Sheets(Sheets.Count))
newSh.Range("A2").Paste
End If
Next
Worksheets("Sheet1").Activate
End Sub
Code:

If this does not meet your needs, then post back with specific comments of what the objective is and where the criteria for search data can be found in the worksheet or other source. Assumptions do not make good code.

 

[DEMI224]

I added a worksheet for each year, so that's not an issue anymore. All I need is to find every date that contains "2000" (for example), copy that cell and 2 on each side of it, and paste it into the worksheet named "2000." I need all of the data from 2000 in one worksheet. I'll have to do this for other years too, but only a few so I feel like it'd be easier to just change the year and re-run the code than to try to put this mess into a loop.

 

[JLGWhiz]

I added a worksheet for each year, so that's not an issue anymore. All I need is to find every date that contains "2000" (for example), copy that cell and 2 on each side of it, and paste it into the worksheet named "2000." I need all of the data from 2000 in one worksheet. I'll have to do this for other years too, but only a few so I feel like it'd be easier to just change the year and re-run the code than to try to put this mess into a loop.

Well, DEMI, maybe this will fill the bill. This code provides an input box so you can specify the year you want to find. If found, VBA will check the column number it is found in and if it is 1 or 2 it will compensate for the offset, so that you do not get the run time error. It also compensates when copying and pasting to the other worksheet by moving the paste column over to the equivalent column for the offset. That is it will start in column A or B, but it will not add any more cells to the right of the found item. Give it a try on a copy of your workbook or a mock up before installing.

Code:
Sub fnd()
Dim c As Range, srchDat As String, sh As Sheet1, lr2
Set sh = ActiveSheet 'Change this to actual sheet name being searched
Retry:
srchDat = CStr(Application.InputBox("Enter a four digit year", "YEAR TO SEARCH", Type:=1))
If srchDat = "" Then
resp = MsgBox("Invalid Entry. Do you want to re-enter your search data?", vbYesNo + vbQuestion, "ENTRY ERROR")
If resp = vbYes Then
GoTo Retry:
Else
Exit Sub
End If
End If
Set c = ActiveSheet.Cells.Find(What:=srchDat, After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, _
SearchFormat:=False)
If Not c Is Nothing Then
addr = c.Address
Set sh2 = Sheets(srchDat)
Do
lr2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row
c.Value = srchDat
Set c = sh.Cells.FindNext(c)
If c.Column = 2 Then
c.Offset(0, -1).Resize(1, 4).Copy sh2.Range("B" & lr2 + 1)
ElseIf c.Column = 1 Then
c.Resize(1, 3).Copy sh2.Range("C" & lr2 - 1)
Else
c.Offset(0, -2).Resize(1, 5).Copy sh2.Range("A" & lr2 + 1)
End If
Loop While c.Address <> addr
End If
End Sub
Code:

 

[DEMI224]

Thanks! It's way better than anything I've tried...

There are 2 problems I'm still having though:
1) There are 5 columns for each location (dates in the middle), so the dates are located in column 3, 8, 13, 18... up to 2273. I can probably tweek the offset (still working on it), but that leads me to #2.

2) I can't figure out why this is happening (I'm very new to VBA), but rather than searching the whole document for dates, it only goes through the first column it finds. And to add to my confusion, it returns the first entry 158 times and each additional entry 159 times.

Any thoughts? I'm making some progress, but it's pretty slow going...

 

[JLGWhiz]

Thanks! It's way better than anything I've tried...

There are 2 problems I'm still having though:
1) There are 5 columns for each location (dates in the middle), so the dates are located in column 3, 8, 13, 18... up to 2273. I can probably tweek the offset (still working on it), but that leads me to #2.

2) I can't figure out why this is happening (I'm very new to VBA), but rather than searching the whole document for dates, it only goes through the first column it finds. And to add to my confusion, it returns the first entry 158 times and each additional entry 159 times.

Any thoughts? I'm making some progress, but it's pretty slow going...

Since I cannot see your data base, it is difficult to explain why it is only looking at the first column. The ActiveSheet.Cells.Find command tells it to start at the upperleft corner of the sheet Cell A1 an proceed across and down. The FindNext command shouldprevent it from looping back through because it has in there a stopper withe the c.address<>addr statement.

I would have to step through the procedure to see what it is actually doing, to be able to offer any fixes on it, since I cannot duplicate the process here. You could troubleshoot it yourself by using the function key F8 and walking step by step through it, then you can see what the values of the variables are when it posts a duplicate by hovering the mouse over them.

I don't know at this point what else to tell you.