Copy Dynamic Range problem

[Len]

Hi

I am copying a dynamic range of cells from 12 different worksheets
under workbook A.
I need to select an adjacent range that starts with "OP" ( always at
column A ) on every sheet ( 12 ) and copy
that adjacent range of data without the formula to another workbook B
in each of 12 worksheets
at the next 5 rows of last used cells of column E
E.g. if there is "OP" in the mid of column A, select the current
region starts from column B to O
in sheet "ADP" ( out of 12 sheets ) under workbook A and copy (without
the formula ) paste to sheet"ADP" ( out of 12 sheets ) under workbook
B
at the next 5 rows of last used cells of column E

Below is the extract of draft excel vba code for a single sheet seems
to be incomplete as it copies row by row and does not work as
intended, further I have no idea how to design excel vba for multiple
sheets

Dim wsNew As Worksheet
Dim OpWs As Worksheet
Dim sTarget As String
Dim i As Integer

Sheets.Add Before:=Sheets(1)
Set OpWs = ActiveSheet

Workbooks.Open Filename:="C:\Budget Final\Acad\ADP.xls"
Windows("ADP.xls").Activate
Set wsNew = Sheets("P+L")
sTarget = "OP"
With Worksheets("P+L")
iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

For i = 1 To iLastRow
If .Cells(i, "A").Value = sTarget Then
iNextRow = iNextRow + 1

.Rows(i).Copy OpWs.Cells(iNextRow, "A")
End If
Next i
End With

Appreciate any help to solve the above problem as I'm excel vba
beginner

Many thanks

Warm regards
Len

 

[joel]

See if this works. Not sure if you have more than one workbook. I'
opening a second workbook and putting the data in a new sheet in th
workbook where the macro is located..

Sub getdata()

fileToOpen = Application _
.GetOpenFilename("Excel Files (*.xls), *.xls")
If fileToOpen = False Then
MsgBox ("Cannot open file - Exiting Macro")
Exit Sub
End If

Set bk = Workbooks.Open(Filename:=fileToOpen)

With ThisWorkbook
Set NewSht = .Sheets.Add(before:=.Sheets(1))
NewSht.Name = "Summary"

For Each Sht In bk.Sheets
If Sht.Name <> "Summary" Then
With Sht
Set c = .Columns("A").Find(what:="OP", _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
MsgBox ("Could not find OP in sheet : " & Sht.Name)
Else
LastRow = .Range("E" & Rows.Count).End(xlUp).Row
FirstRow = LastRow - 4

If LastRow <= c.Row Then
MsgBox ("There are no rows to copy on sheet : "
Sht.Name)
Else

If FirstRow <= c.Row Then
FirstRow = c.Row + 1
End If

Set Copyrange = .Range("B" & FirstRow & ":O"
LastRow)

With NewSht
LastRow = .Range("E" & Rows.Count).End(xlUp).Row
NewRow = LastRow + 1
Copyrange.Copy
.Range("B" & LastRow).PasteSpecial _
Paste:=xlPasteValues
End With
End If
End If
End With
End If
Next Sht
End With

bk.Close savechznges:=False
End Su

 

[Len]

See if this works.  Not sure if you have more than one workbook.  I'm
opening a second workbook and putting the data in a new sheet in the
workbook where the macro is located..

Sub getdata()

fileToOpen = Application _
.GetOpenFilename("Excel Files (*.xls), *.xls")
If fileToOpen = False Then
MsgBox ("Cannot open file - Exiting Macro")
Exit Sub
End If

Set bk = Workbooks.Open(Filename:=fileToOpen)

With ThisWorkbook
Set NewSht = .Sheets.Add(before:=.Sheets(1))
NewSht.Name = "Summary"

For Each Sht In bk.Sheets
If Sht.Name <> "Summary" Then
With Sht
Set c = .Columns("A").Find(what:="OP", _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
MsgBox ("Could not find OP in sheet : " & Sht.Name)
Else
LastRow = .Range("E" & Rows.Count).End(xlUp).Row
FirstRow = LastRow - 4

If LastRow <= c.Row Then
MsgBox ("There are no rows to copy on sheet : " &
Sht.Name)
Else

If FirstRow <= c.Row Then
FirstRow = c.Row + 1
End If

Set Copyrange = .Range("B" & FirstRow & ":O" &
LastRow)

With NewSht
LastRow = .Range("E" & Rows.Count).End(xlUp).Row
NewRow = LastRow + 1
Copyrange.Copy
.Range("B" & LastRow).PasteSpecial _
Paste:=xlPasteValues
End With
End If
End If
End With
End If
Next Sht
End With

bk.Close savechznges:=False
End Sub

--
joel
------------------------------------------------------------------------
joel's Profile: 229
View this thread:http://www.thecodecage.com/forumz/showthread.php?t=168586

Microsoft Office Help

Hi Joel,

Thanks for your prompt reply
After I run your codes and the result copies the wrong range
Your codes copy the adjacent range at the last used rows ( ie wrong
range ), instead it should copy the row starting below immediately
after the row which found "OP" in cloumn A until the last used rows
from column B to column O
The correct range to copy should cover the current region starting row
"OP" until the last used row from column B to column O

I try to fix your codes but it does not work

Regards
Len

 

[joel]

You posting wasn't clear and most people want it the way I did it.
also understand why you want it the other way. sorry!

Try these changes


From

LastRow = .Range("E" & Rows.Count).End(xlUp).Row
FirstRow = LastRow - 4

If LastRow <= c.Row Then
MsgBox ("There are no rows to copy on sheet : " & Sht.Name)
Else

If FirstRow <= c.Row Then
FirstRow = c.Row + 1
End If

To

EndRow = .Range("E" & Rows.Count).End(xlUp).Row

If EndRow <= c.Row Then
MsgBox ("There are no rows to copy on sheet : " & Sht.Name)
Else
FirstRow = c.row + 1
LastRow = FirstRow + 4

If LastRow > EndRow Then
LastRow = Endrow
End I

 

[Len]

You posting wasn't clear and most people want it the way I did it.  I
also understand why you want it the other way.  sorry!

Try these changes

From

LastRow = .Range("E" & Rows.Count).End(xlUp).Row
FirstRow = LastRow - 4

If LastRow <= c.Row Then
MsgBox ("There are no rows to copy on sheet : " & Sht.Name)
Else

If FirstRow <= c.Row Then
FirstRow = c.Row + 1
End If

To

EndRow = .Range("E" & Rows.Count).End(xlUp).Row

If EndRow <= c.Row Then
MsgBox ("There are no rows to copy on sheet : " & Sht.Name)
Else
FirstRow = c.row + 1
LastRow = FirstRow + 4

If LastRow > EndRow Then
LastRow = Endrow
End If

--
joel
------------------------------------------------------------------------
joel's Profile: 229
View this thread:http://www.thecodecage.com/forumz/showthread.php?t=168586

Microsoft Office Help

Hi Joel,

Sorry........... my earlier post not clear and now your modified codes
works perfectly

Thanks alot

Regards
Len