Macro help.
 

have been given a macro but I need to amend it and wondered if anyone
can help. What happens at the mo is

Starts in Sheet 1 in a cell that you pick (usually row 7 column A)
- Checks that row if it's blank
- If it's not blank, copy the row to sheet 2 (row 1)
- if it is blank, check the next row for data.
- If the next row has data, copy that data after the last copied data
in sheet 2 (row 2)
- if it's blank, quit.
- Keep checking for blank rows and copying into sheet two until it
comes to two consecutive rows that are blank.

What I need it to do is start in sheet 1 as it does now but instead of
looking in column A for blank rows I need it to look in Columns AF & BL
and if there is no data in either row I need it to check the next row
and then copy if there any in there. Also being a pain if theres data
in columns AF or BL I need the data in the rows in columns C,D,E to
copy over too.

Macro shown below.
' Macro2 Macro
' Macro recorded 07/07/2006 by Masters
'Option Explicit

Sub test()
Dim wks1 As Worksheet, wks2 As Worksheet
Dim LastRow As Long, StartRow As Long, x As Long
Dim rng1 As Range, rng2 As Range, FinishRow As Long
Dim fn As WorksheetFunction

Set fn = Application.WorksheetFunction
Set wks1 = ThisWorkbook.Sheets("Sheet2")
Set wks2 = ThisWorkbook.Sheets("Sheet4")

wks2.Cells.ClearContents

With wks1
On Error Resume Next
StartRow = _
Application.InputBox(Prompt:="Select any cell in your beginning row",
Type:=8).Row
If Not IsNumeric(StartRow) Then Exit Sub
Err.Clear
On Error GoTo 0

LastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
FinishRow = LastRow
For x = StartRow To LastRow
If fn.CountA(.Rows(x)) = 0 And fn.CountA(.Rows(x + 1)) = 0 Then
FinishRow = fn.Max(StartRow, x - 1)
Exit For
End If
Next x
Set rng1 = .Range(.Cells(StartRow, 1), .Cells(FinishRow, 256))
rng1.Copy wks2.Range("A1")
End With

With wks2
LastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
For x = LastRow To 1 Step -1
If fn.CountA(.Rows(x)) = 0 Then .Rows(x).Delete shift:=xlUp
Next x
End With

End Sub


Many many thanks to all the helpful crew on here


--
tweacle

Macro help.
 

try this idea
Sub copyifboth()
lr = Cells(Rows.Count, "a").End(xlUp).Row
'For i = 2 To lr ' if not deleting rows
For i = lr To 2 Step -1'assumes header in row 1
If Len(Cells(i, "a")) 1 And Len(Cells(i, "b")) 1 Then _
MsgBox Cells(i, 1).Row
Next i
End Sub

--
Don Guillett
SalesAid Software

"tweacle" wrote in message
...

have been given a macro but I need to amend it and wondered if anyone
can help. What happens at the mo is

Starts in Sheet 1 in a cell that you pick (usually row 7 column A)
- Checks that row if it's blank
- If it's not blank, copy the row to sheet 2 (row 1)
- if it is blank, check the next row for data.
- If the next row has data, copy that data after the last copied data
in sheet 2 (row 2)
- if it's blank, quit.
- Keep checking for blank rows and copying into sheet two until it
comes to two consecutive rows that are blank.

What I need it to do is start in sheet 1 as it does now but instead of
looking in column A for blank rows I need it to look in Columns AF & BL
and if there is no data in either row I need it to check the next row
and then copy if there any in there. Also being a pain if theres data
in columns AF or BL I need the data in the rows in columns C,D,E to
copy over too.

Macro shown below.
' Macro2 Macro
' Macro recorded 07/07/2006 by Masters
'Option Explicit

Sub test()
Dim wks1 As Worksheet, wks2 As Worksheet
Dim LastRow As Long, StartRow As Long, x As Long
Dim rng1 As Range, rng2 As Range, FinishRow As Long
Dim fn As WorksheetFunction

Set fn = Application.WorksheetFunction
Set wks1 = ThisWorkbook.Sheets("Sheet2")
Set wks2 = ThisWorkbook.Sheets("Sheet4")

wks2.Cells.ClearContents

With wks1
On Error Resume Next
StartRow = _
Application.InputBox(Prompt:="Select any cell in your beginning row",
Type:=8).Row
If Not IsNumeric(StartRow) Then Exit Sub
Err.Clear
On Error GoTo 0

LastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
FinishRow = LastRow
For x = StartRow To LastRow
If fn.CountA(.Rows(x)) = 0 And fn.CountA(.Rows(x + 1)) = 0 Then
FinishRow = fn.Max(StartRow, x - 1)
Exit For
End If
Next x
Set rng1 = .Range(.Cells(StartRow, 1), .Cells(FinishRow, 256))
rng1.Copy wks2.Range("A1")
End With

With wks2
LastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
For x = LastRow To 1 Step -1
If fn.CountA(.Rows(x)) = 0 Then .Rows(x).Delete shift:=xlUp
Next x
End With

End Sub


Many many thanks to all the helpful crew on here


--
tweacle