Here is the code I have now, and what I need it to do.

Sub Data_Extract()
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim WS3 As Worksheet
Dim WS4 As Worksheet

Dim rng1 As Range
Dim rng2 As Range

Dim Str As String

Set WS1 = Sheets("Summary")
Set WS2 = Sheets("Credits")
Set WS3 = Sheets("Payroll")
Set WS4 = Sheets("Macros")


WS3.Select
Range("A5:AA1500").Select
Selection.Copy
WS4.Select
Range("A1").Select
ActiveSheet.Paste

Do Until IsEmpty(ActiveCell)
Set rng1 = WS4.Range("A2:AA1497").CurrentRegion
Str = WS4.Range("C2").Value
WS4.Select
WS4.AutoFilterMode = Flase
rng1.AutoFilter Field:=3, Criteria:=Str
WIth WS4.AutoFilter.Range
On Error Resume Next
Set rng2 = .Offset(1,0).Resize(.Rows.Count - 1, .Columns.Count)
..SpecialCells (xlCellTypeVariable)


'HERE IS WHERE I NEED HELP!!!!!
WS2.Select
Range("K5").Select 'Data Field to Copy
Selection.Copy
WS1.Select
Range("A8").Select 'First Cell on sheet where data needs to go
' I need this to look for the next blank cell on the page and then paste the
value of
' The Data Field to Copy there.
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False
'Then on the same Row I need it to do the following....
'If value of cell AV9=AX3 on WS2 it needs to copy value from WS2 cell AV70 to
'the same row in colum B.
'END HELP NEEDED SECTION !!!!


WS2.Select
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
WS2.Select
Range("A10:AA69").ClearContents
If Not rng2 Is Nothing Then
rng2.Copy WS2.Range("A1" & LastRow(WS2) + 0)
rng2.EntireRow.Delete
End If
End With
WS4.AutoFilterMode = False
WS4.Select
Range("C2").Activate
Loop
End Sub


Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", After:=sh.Range("A6:AA1497"),
LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious,
MatchCase:=False).Row
On Error GoTo 0
End Function

'HERE IS WHERE I NEED HELP!!!!!
WS2.Select
Range("K5").Select 'Data Field to Copy
Selection.Copy
WS1.Select
Range("A8").Select 'First Cell on sheet where data needs to go
do while isempty(selection)
selection.offset(1,0).Select
Loop
' I need this to look for the next blank cell on the page and then paste the
value of
' The Data Field to Copy there.
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False
'Then on the same Row I need it to do the following....
'If value of cell AV9=AX3 on WS2 it needs to copy value from WS2 cell AV70 to
'the same row in colum B.
if Range("AV9").Value = ws2.Range("AX3").Value then
ws2.Range("AV70").copy cells(selection.row,"B")
End if
'END HELP NEEDED SECTION !!!!

--
Regards,
Tom Ogilvy

"trward79" wrote:

Here is the code I have now, and what I need it to do.

Sub Data_Extract()
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim WS3 As Worksheet
Dim WS4 As Worksheet

Dim rng1 As Range
Dim rng2 As Range

Dim Str As String

Set WS1 = Sheets("Summary")
Set WS2 = Sheets("Credits")
Set WS3 = Sheets("Payroll")
Set WS4 = Sheets("Macros")


WS3.Select
Range("A5:AA1500").Select
Selection.Copy
WS4.Select
Range("A1").Select
ActiveSheet.Paste

Do Until IsEmpty(ActiveCell)
Set rng1 = WS4.Range("A2:AA1497").CurrentRegion
Str = WS4.Range("C2").Value
WS4.Select
WS4.AutoFilterMode = Flase
rng1.AutoFilter Field:=3, Criteria:=Str
WIth WS4.AutoFilter.Range
On Error Resume Next
Set rng2 = .Offset(1,0).Resize(.Rows.Count - 1, .Columns.Count)
.SpecialCells (xlCellTypeVariable)


'HERE IS WHERE I NEED HELP!!!!!
WS2.Select
Range("K5").Select 'Data Field to Copy
Selection.Copy
WS1.Select
Range("A8").Select 'First Cell on sheet where data needs to go
' I need this to look for the next blank cell on the page and then paste the
value of
' The Data Field to Copy there.
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False
'Then on the same Row I need it to do the following....
'If value of cell AV9=AX3 on WS2 it needs to copy value from WS2 cell AV70 to
'the same row in colum B.
'END HELP NEEDED SECTION !!!!


WS2.Select
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
WS2.Select
Range("A10:AA69").ClearContents
If Not rng2 Is Nothing Then
rng2.Copy WS2.Range("A1" & LastRow(WS2) + 0)
rng2.EntireRow.Delete
End If
End With
WS4.AutoFilterMode = False
WS4.Select
Range("C2").Activate
Loop
End Sub


Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", After:=sh.Range("A6:AA1497"),
LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious,
MatchCase:=False).Row
On Error GoTo 0
End Function

Tom,

It is not scrolling down to the next blank, but filling in Cell A8.
The second issue is the value from AV70 is comming up as #REF because it is
a formula, and changes. I need it to copy the value of cell AV70 to B.

Any sugestions will help. And Thanks A Million for the help so far.

"Tom Ogilvy" wrote:

'HERE IS WHERE I NEED HELP!!!!!
WS2.Select
Range("K5").Select 'Data Field to Copy
Selection.Copy
WS1.Select
Range("A8").Select 'First Cell on sheet where data needs to go
do while isempty(selection)
selection.offset(1,0).Select
Loop
' I need this to look for the next blank cell on the page and then paste the
value of
' The Data Field to Copy there.
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False
'Then on the same Row I need it to do the following....
'If value of cell AV9=AX3 on WS2 it needs to copy value from WS2 cell AV70 to
'the same row in colum B.
if Range("AV9").Value = ws2.Range("AX3").Value then
ws2.Range("AV70").copy cells(selection.row,"B")
End if
'END HELP NEEDED SECTION !!!!

--
Regards,
Tom Ogilvy

"trward79" wrote:

Here is the code I have now, and what I need it to do.

Sub Data_Extract()
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim WS3 As Worksheet
Dim WS4 As Worksheet

Dim rng1 As Range
Dim rng2 As Range

Dim Str As String

Set WS1 = Sheets("Summary")
Set WS2 = Sheets("Credits")
Set WS3 = Sheets("Payroll")
Set WS4 = Sheets("Macros")


WS3.Select
Range("A5:AA1500").Select
Selection.Copy
WS4.Select
Range("A1").Select
ActiveSheet.Paste

Do Until IsEmpty(ActiveCell)
Set rng1 = WS4.Range("A2:AA1497").CurrentRegion
Str = WS4.Range("C2").Value
WS4.Select
WS4.AutoFilterMode = Flase
rng1.AutoFilter Field:=3, Criteria:=Str
WIth WS4.AutoFilter.Range
On Error Resume Next
Set rng2 = .Offset(1,0).Resize(.Rows.Count - 1, .Columns.Count)
.SpecialCells (xlCellTypeVariable)


'HERE IS WHERE I NEED HELP!!!!!
WS2.Select
Range("K5").Select 'Data Field to Copy
Selection.Copy
WS1.Select
Range("A8").Select 'First Cell on sheet where data needs to go
' I need this to look for the next blank cell on the page and then paste the
value of
' The Data Field to Copy there.
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False
'Then on the same Row I need it to do the following....
'If value of cell AV9=AX3 on WS2 it needs to copy value from WS2 cell AV70 to
'the same row in colum B.
'END HELP NEEDED SECTION !!!!


WS2.Select
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
WS2.Select
Range("A10:AA69").ClearContents
If Not rng2 Is Nothing Then
rng2.Copy WS2.Range("A1" & LastRow(WS2) + 0)
rng2.EntireRow.Delete
End If
End With
WS4.AutoFilterMode = False
WS4.Select
Range("C2").Activate
Loop
End Sub


Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", After:=sh.Range("A6:AA1497"),
LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious,
MatchCase:=False).Row
On Error GoTo 0
End Function

'HERE IS WHERE I NEED HELP!!!!!
WS2.Select
Range("K5").Select 'Data Field to Copy
Selection.Copy
WS1.Select
Range("A8").Select 'First Cell on sheet where data needs to go
do while NOT isempty(selection)
selection.offset(1,0).Select
Loop
' I need this to look for the next blank cell on the page and then paste the
value of
' The Data Field to Copy there.
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False
'Then on the same Row I need it to do the following....
'If value of cell AV9=AX3 on WS2 it needs to copy value from WS2 cell AV70 to
'the same row in colum B.
if Range("AV9").Value = ws2.Range("AX3").Value then
cells(selection.row,"B").Value = ws2.Range("AV70").Value
End if
'END HELP NEEDED SECTION !!!!

--
Regards,
Tom Ogilvy

"trward79" wrote:

Tom,

It is not scrolling down to the next blank, but filling in Cell A8.
The second issue is the value from AV70 is comming up as #REF because it is
a formula, and changes. I need it to copy the value of cell AV70 to B.

Any sugestions will help. And Thanks A Million for the help so far.

"Tom Ogilvy" wrote:

'HERE IS WHERE I NEED HELP!!!!!
WS2.Select
Range("K5").Select 'Data Field to Copy
Selection.Copy
WS1.Select
Range("A8").Select 'First Cell on sheet where data needs to go
do while isempty(selection)
selection.offset(1,0).Select
Loop
' I need this to look for the next blank cell on the page and then paste the
value of
' The Data Field to Copy there.
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False
'Then on the same Row I need it to do the following....
'If value of cell AV9=AX3 on WS2 it needs to copy value from WS2 cell AV70 to
'the same row in colum B.
if Range("AV9").Value = ws2.Range("AX3").Value then
ws2.Range("AV70").copy cells(selection.row,"B")
End if
'END HELP NEEDED SECTION !!!!

--
Regards,
Tom Ogilvy

"trward79" wrote:

Here is the code I have now, and what I need it to do.

Sub Data_Extract()
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim WS3 As Worksheet
Dim WS4 As Worksheet

Dim rng1 As Range
Dim rng2 As Range

Dim Str As String

Set WS1 = Sheets("Summary")
Set WS2 = Sheets("Credits")
Set WS3 = Sheets("Payroll")
Set WS4 = Sheets("Macros")


WS3.Select
Range("A5:AA1500").Select
Selection.Copy
WS4.Select
Range("A1").Select
ActiveSheet.Paste

Do Until IsEmpty(ActiveCell)
Set rng1 = WS4.Range("A2:AA1497").CurrentRegion
Str = WS4.Range("C2").Value
WS4.Select
WS4.AutoFilterMode = Flase
rng1.AutoFilter Field:=3, Criteria:=Str
WIth WS4.AutoFilter.Range
On Error Resume Next
Set rng2 = .Offset(1,0).Resize(.Rows.Count - 1, .Columns.Count)
.SpecialCells (xlCellTypeVariable)


'HERE IS WHERE I NEED HELP!!!!!
WS2.Select
Range("K5").Select 'Data Field to Copy
Selection.Copy
WS1.Select
Range("A8").Select 'First Cell on sheet where data needs to go
' I need this to look for the next blank cell on the page and then paste the
value of
' The Data Field to Copy there.
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False
'Then on the same Row I need it to do the following....
'If value of cell AV9=AX3 on WS2 it needs to copy value from WS2 cell AV70 to
'the same row in colum B.
'END HELP NEEDED SECTION !!!!


WS2.Select
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
WS2.Select
Range("A10:AA69").ClearContents
If Not rng2 Is Nothing Then
rng2.Copy WS2.Range("A1" & LastRow(WS2) + 0)
rng2.EntireRow.Delete
End If
End With
WS4.AutoFilterMode = False
WS4.Select
Range("C2").Activate
Loop
End Sub


Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", After:=sh.Range("A6:AA1497"),
LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious,
MatchCase:=False).Row
On Error GoTo 0
End Function