Next Cell Empty Issues

  • Thread starter Thread starter Guest
  • Start date Start date
G

Guest

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 !!!!
 
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.
 
'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 !!!!
 
Back
Top