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

What does custom number format of ;;; mean?
Three semi-colons will hide the value in the cell. Although most people use white font instead.
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

Keebler
  • Solved
new project: copy range without empty or blank rows
5 6 7
Replies
68
Views
1K
Keebler
Keebler
E
  • Question
Estimating Spreadsheet-Summing
Replies
1
Views
127
Peter_SSs
Peter_SSs
E
  • Solved
Summing Values
Replies
3
Views
204
LazyBug
LazyBug
N
  • Solved
Copy/paste a row from within a loop, before that loop moves on to next cell
Replies
5
Views
222
Joe4
Joe4
J
  • Question
Run-time error '91"- bypass and add comment
Replies
3
Views
503
Alex Blakenburg
A

Forum statistics

Threads
1,214,568
Messages
6,120,272
Members
448,953
Latest member
Dutchie_1

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