Macro need multiple rows per sheet. Not working

C

cSciFiChick

New Member
Joined
Jul 31, 2014
Messages
42
So I have this Marco to copy from each tab onto a single tab. The problem is I need 48 rows from each tab copied over and it is only doing that for the last one.

Here are the results:
SheetJob NoChange Order NoChange Order SeqDateOwner CO NoStatus
501X5 - Test Sheet501X50225000
501X502200
PCO# 2 - CCO# Pending202210
202200
PCO# 1 - CCO# Pending1022400
102200
400
700
800
91001
1100
1200


Here is my Macro:

Sub CopyRangeFromMultiWorksheets2()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range

aRange = "C3"
bRange = "B8:B55"
cRange = "F8:F55"
dRange = "H8:H55"
eRange = "G8:G55"

lRow = 2
With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Delete the sheet "RDBMergeSheet2" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet2").Delete
On Error GoTo 0
Application.DisplayAlerts = True

'Add a worksheet with the name "RDBMergeSheet2"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet2"
DestSh.Range("A1:L1").Value = Array("Sheet", "Job No", "Change Order No", "Change Order Seq", "Date", "Owner CO No", "Status", "Change to Contract", "Change to Cost", "Units", "Comments", "Description")
Range("Z1").Value = "Headers"

'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets

'Loop through all worksheets except the RDBMerge worksheet and the
'Information worksheet, you can ad more sheets to the array if you want.
If IsError(Application.Match(sh.Name, _
Array(DestSh.Name, "1 - Accubid Data", "2 - Quoted Materials", "Summary-Sheet", "Header", "Details", "PCO# Template - CCO# Pending", "FD#Template - PCO# Pending", "List"), 0)) Then
'Comment out the following line if you don't want to
'include worksheet names in the summary sheet
Cells(lRow, 1) = sh.Name
'If you commented out the previous line, make a change
'in the following line: change (lRow, 2) to (lRow, 1)
sh.Range(aRange).Copy
Cells(lRow, 2).PasteSpecial xlPasteValues
Cells(lRow, 3).FormulaR1C1 = "0"
sh.Range(bRange).Copy
Cells(lRow, 4).PasteSpecial xlPasteValues
Cells(lRow, 5).FormulaR1C1 = "=IF(AND(RC[2]=0,RC[-1]=4),5,IF(RC[2]=0,2,1))"
sh.Range(cRange).Copy
Cells(lRow, 6).PasteSpecial xlPasteValues
Cells(lRow, 7).FormulaR1C1 = "0"
lRow = lRow + 1
sh.Range(aRange).Copy
Cells(lRow, 2).PasteSpecial xlPasteValues
Cells(lRow, 3).FormulaR1C1 = "0"
sh.Range(bRange).Copy
Cells(lRow, 4).PasteSpecial xlPasteValues
Cells(lRow, 5).FormulaR1C1 = "=IF(AND(RC[2]=0,RC[-1]=4),5,IF(RC[2]=0,2,1))"
sh.Range(dRange).Copy
Cells(lRow, 6).PasteSpecial xlPasteValues
sh.Range(eRange).Copy
Cells(lRow, 7).PasteSpecial xlPasteValues
lRow = lRow + 1

End If






Next

ExitTheSub:

Application.GoTo DestSh.Cells(1)

'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Click to expand...
 

Excel Facts

VLOOKUP to Left?
Use =VLOOKUP(A2,CHOOSE({1,2},$Z$1:$Z$99,$Y$1:$Y$99),2,False) to lookup Y values to left of Z values.
Sort by date Sort by votes
Try his:

VBA Code: 
Sub CopyRangeFromMultiWorksheets2()
  Dim sh As Worksheet, DestSh As Worksheet
  Dim lRow As Long
  Dim CopyRng As Range
  Dim aRange As String, bRange As String, cRange As String, dRange As String, eRange As String
  
  aRange = "C3"
  bRange = "B8:B55"
  cRange = "F8:F55"
  dRange = "H8:H55"
  eRange = "G8:G55"
  
  lRow = 2
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
  End With
  
  'Delete the sheet "RDBMergeSheet2" if it exist
  On Error Resume Next
  ActiveWorkbook.Worksheets("RDBMergeSheet2").Delete
  On Error GoTo 0
  
  'Add a worksheet with the name "RDBMergeSheet2"
  Set DestSh = ActiveWorkbook.Worksheets.Add
  DestSh.Name = "RDBMergeSheet2"
  DestSh.Range("A1:L1").Value = Array("Sheet", "Job No", "Change Order No", "Change Order Seq", "Date", "Owner CO No", "Status", "Change to Contract", "Change to Cost", "Units", "Comments", "Description")
  Range("Z1").Value = "Headers"
  
  'loop through all worksheets and copy the data to the DestSh
  For Each sh In ActiveWorkbook.Worksheets
  
    'Loop through all worksheets except the RDBMerge worksheet and the
    'Information worksheet, you can ad more sheets to the array if you want.
    Select Case sh.Name
    
    Case DestSh.Name, "1 - Accubid Data", "2 - Quoted Materials", "Summary-Sheet", "Header", _
        "Details", "PCO# Template - CCO# Pending", "FD#Template - PCO# Pending", "List"
         
    Case Else
      'Comment out the following line if you don't want to
      'include worksheet names in the summary sheet
      DestSh.Cells(lRow, 1) = sh.Name
      'If you commented out the previous line, make a change
      'in the following line: change (lRow, 2) to (lRow, 1)
      sh.Range(aRange).Copy
      DestSh.Cells(lRow, 2).PasteSpecial xlPasteValues
      DestSh.Cells(lRow, 3).FormulaR1C1 = "0"
      sh.Range(bRange).Copy
      DestSh.Cells(lRow, 4).PasteSpecial xlPasteValues
      DestSh.Cells(lRow, 5).FormulaR1C1 = "=IF(AND(RC[2]=0,RC[-1]=4),5,IF(RC[2]=0,2,1))"
      sh.Range(cRange).Copy
      DestSh.Cells(lRow, 6).PasteSpecial xlPasteValues
      DestSh.Cells(lRow, 7).FormulaR1C1 = "0"
      
      'The following part seems to me to be duplicated:
'      lRow = lRow + 1
'      sh.Range(aRange).Copy
'      DestSh.Cells(lRow, 2).PasteSpecial xlPasteValues
'      DestSh.Cells(lRow, 3).FormulaR1C1 = "0"
'      sh.Range(bRange).Copy
'      DestSh.Cells(lRow, 4).PasteSpecial xlPasteValues
'      DestSh.Cells(lRow, 5).FormulaR1C1 = "=IF(AND(RC[2]=0,RC[-1]=4),5,IF(RC[2]=0,2,1))"
'      sh.Range(dRange).Copy
'      DestSh.Cells(lRow, 6).PasteSpecial xlPasteValues
'      sh.Range(eRange).Copy
'      DestSh.Cells(lRow, 7).PasteSpecial xlPasteValues

      lRow = lRow + 49
    End Select
  Next
  
  DestSh.Select
  Cells(1).Select
  DestSh.Columns.AutoFit  'AutoFit the column width in the DestSh sheet
  
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
  End With
End Sub

Note Code Tag:
In future please use code tags when posting code.
How to Post Your VBA Code it makes your code easier to read and copy and it also maintains VBA formatting.

----- --
 
Upvote 0
Thank you that is actually close but do you know how to get these to go down the 49 rows as well?

SheetJob NoChange Order NoChange Order SeqDateOwner CO NoStatus
501X5 - Test Sheet501X50225000
40


'in the following line: change (lRow, 2) to (lRow, 1)
sh.Range(aRange).Copy
DestSh.Cells(lRow, 2).PasteSpecial xlPasteValues
DestSh.Cells(lRow, 3).FormulaR1C1 = "0"
sh.Range(bRange).Copy
DestSh.Cells(lRow, 4).PasteSpecial xlPasteValues
DestSh.Cells(lRow, 5).FormulaR1C1 = "=IF(AND(RC[2]=0,RC[-1]=4),5,IF(RC[2]=0,2,1))"
sh.Range(cRange).Copy
DestSh.Cells(lRow, 6).PasteSpecial xlPasteValues
DestSh.Cells(lRow, 7).FormulaR1C1 = "0"

These ones where I want it to enter 0 and the formula down all the rows:

DestSh.Cells(lRow, 3).FormulaR1C1 = "0"
DestSh.Cells(lRow, 5).FormulaR1C1 = "=IF(AND(RC[2]=0,RC[-1]=4),5,IF(RC[2]=0,2,1))"
DestSh.Cells(lRow, 7).FormulaR1C1 = "0"
 
Upvote 0
cSciFiChick said:
do you know how to get these to go down the 49 rows as well?
Click to expand...

Try this:

VBA Code: 
Sub CopyRangeFromMultiWorksheets2()
  Dim sh As Worksheet, DestSh As Worksheet
  Dim lRow As Long
  Dim CopyRng As Range
  Dim aRange As String, bRange As String, cRange As String, dRange As String, eRange As String
  
  aRange = "C3"
  bRange = "B8:B55"
  cRange = "F8:F55"
  dRange = "H8:H55"
  eRange = "G8:G55"
  
  lRow = 2
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
  End With
  
  'Delete the sheet "RDBMergeSheet2" if it exist
  On Error Resume Next
  ActiveWorkbook.Worksheets("RDBMergeSheet2").Delete
  On Error GoTo 0
  
  'Add a worksheet with the name "RDBMergeSheet2"
  Set DestSh = ActiveWorkbook.Worksheets.Add
  DestSh.Name = "RDBMergeSheet2"
  DestSh.Range("A1:L1").Value = Array("Sheet", "Job No", "Change Order No", "Change Order Seq", "Date", "Owner CO No", "Status", "Change to Contract", "Change to Cost", "Units", "Comments", "Description")
  Range("Z1").Value = "Headers"
  
  'loop through all worksheets and copy the data to the DestSh
  For Each sh In ActiveWorkbook.Worksheets
  
    'Loop through all worksheets except the RDBMerge worksheet and the
    'Information worksheet, you can ad more sheets to the array if you want.
    Select Case sh.Name
    
    Case DestSh.Name, "1 - Accubid Data", "2 - Quoted Materials", "Summary-Sheet", "Header", _
        "Details", "PCO# Template - CCO# Pending", "FD#Template - PCO# Pending", "List"
         
    Case Else
      'Comment out the following line if you don't want to
      'include worksheet names in the summary sheet
      DestSh.Cells(lRow, 1).Resize(48).Value = sh.Name
      DestSh.Cells(lRow, 2).Resize(48).Value = sh.Range(aRange)
      DestSh.Cells(lRow, 3).Resize(48).Value = "0"
      sh.Range(bRange).Copy
      DestSh.Cells(lRow, 4).PasteSpecial xlPasteValues
      DestSh.Cells(lRow, 5).Resize(48).FormulaR1C1 = "=IF(AND(RC[2]=0,RC[-1]=4),5,IF(RC[2]=0,2,1))"
      sh.Range(cRange).Copy
      DestSh.Cells(lRow, 6).PasteSpecial xlPasteValues
      DestSh.Cells(lRow, 7).Resize(48).FormulaR1C1 = "0"
      
      lRow = lRow + 49
    End Select
  Next
  
  DestSh.Select
  Cells(1).Select
  DestSh.Columns.AutoFit  'AutoFit the column width in the DestSh sheet
  
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
  End With
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Solved
Speeding up VBA
Replies
9
Views
269
jvoss
J
W
  • Solved
Add a column w/ formula to copy / paste macro
Replies
5
Views
306
wknight7
W
Keebler
  • Solved
new project: copy range without empty or blank rows
5 6 7
Replies
68
Views
2K
Keebler
Keebler
E
  • Question Question
Estimating Spreadsheet-Summing
Replies
1
Views
350
Peter_SSs
Peter_SSs
E
  • Solved
Summing Values
Replies
3
Views
551
LazyBug
LazyBug

Forum statistics

Threads
1,224,813
Messages
6,181,115
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top