VBA Macro Consolidate Data From Discontiguous Cells In Multiple Sheets To One Master

**tinamiller1** · 08-22-2013, 12:35 AM

I have a macro that copies multiple cells from my 301 worksheets in a workbook to 1 sheet. All of the cells are consistent as far as placement and contain text value except for 1 cell that is a summation of other cells. I am not quite sure how to code that particular portion so it copies the value only and pastes it in the worksheet. This would be similiar to doing a copy paste special but since I have 301 worksheets, I don't want to manually do this. Here is my code: cell j43 is the summation cell.

Code:

'seventh macro
'copy cells
Sub copycells()
Dim WS As Worksheet, wsum As Worksheet
Dim wb As Workbook
Dim vws As Variant 'Need to use a Variant for iterator
Dim i As Integer, j As String, k As String 

i = 0
Set wb = Workbooks("sheet4.xlsm")
Set wsum = wb.Sheets("summary") 

'Iterate through the sheets
For Each vws In wb.Sheets
If vws.Name <> "summary" Then
j = CStr(i + 2)
k = CStr(i + 18)
vws.Range("b8").Copy wsum.Range("a" & j)
vws.Range("b9").Copy wsum.Range("b" & j)
vws.Range("b5").Copy wsum.Range("c" & j)
vws.Range("H48").Copy wsum.Range("D" & j)
vws.Range("g13:g31").Copy wsum.Range("e" & j & ":e" & k)
vws.Range("i13:i31").Copy wsum.Range("f" & j & ":f" & k)
vws.Range("j13:j31").Copy wsum.Range("g" & j & ":g" & k)
vws.Range("k13:k31").Copy wsum.Range("h" & j & ":h" & k)
vws.Range("l13:l31").Copy wsum.Range("i" & j & ":i" & k)
vws.Range("k38").Copy wsum.Range("j" & j)
vws.Range("l38").Copy wsum.Range("k" & j)
vws.Range("e2").Copy wsum.Range("l" & j)
Sheets("Sheet4").Range("j43").Copy Destination:=Sheets("summary").Range("m" & j) 

i = i + 18
End If
Next
End Sub

**Mike H** · 08-22-2013, 01:01 AM

Hi,

Change the line for J43 fro the single line of

Code:

Sheets("Sheet4").Range("j43").Copy Destination:=Sheets("summary").Range("m" & j)

To this

Code:

Sheets("Sheet4").Range("j43").Copy
Sheets("summary").Range("m" & j).PasteSpecial Paste:=xlPasteValues

**tinamiller1** · 08-22-2013, 01:12 AM

It does not work right. It first asks if I want to replace the contents of the cells and it will ask until it goes thru all sheets and I click cancel or ok. The 2nd issue is it displays it like this:

737978 737978 737978 291023785101 71424025 $1,050.00 $74,995,226,250.00 Implant Pass-through: Auto Invoice Pricing (AIP) Implant Pass-through: Auto Invoice Pricing (AIP) 12/8/2011
291023785101 71424003 $2,280.00 $162,846,726,840.00 Implant Pass-through: Auto Invoice Pricing (AIP)
291023785101 71421183 $5,211.00 $372,175,784,613.00 Implant Pass-through: Auto Invoice Pricing (AIP)

When I do my code without that summation piece, commented out, it copies like this:

289597855601 737978 4/29/2011 7/12/2012 CEMENT BONE PALACOS 00-1113-140-01 2 $322.86 $645.72 Implant Pass-through: Auto Invoice Pricing (AIP)
289597855601 737978 4/29/2011 7/12/2012 BUNDLED PRICING $- Implant Pass-through: Auto Invoice Pricing (AIP)
289597855601 737978 4/29/2011 7/12/2012 GSF FLX CEM FM/CEM TIB/PRLNG SUR/XLPE PT 98-0002-500-28 1 $4,150.00 $4,150.00 Implant Pass-through: Auto Invoice Pricing (AIP)
289597855601 737978 4/29/2011 7/12/2012 NATURAL KNEE GSF NP FLEX FEM SIZE 3-LT 00-5414-016-01 1 $- Implant Pass-through: Auto Invoice Pricing (AIP)
289597855601 737978 4/29/2011 7/12/2012 NATURAL KNEE FLX PROLNG PATELLA, SIZE 1, 8MM 00-5420-008-01 1 $- Implant Pass-through: Auto Invoice Pricing (AIP)
289597855601 737978 4/29/2011 7/12/2012 NK FLX PRLNG UL CONG ART 00-5428-011-09 1 $- Implant Pass-through: Auto Invoice Pricing (AIP)
289597855601 737978 4/29/2011 7/12/2012 NKII NP STEM TIBIAL BASEPLATE LT, SIZE 2 6307-00-220 1 $- Implant Pass-through: Auto Invoice Pricing (AIP)
289597855601 737978 4/29/2011 7/12/2012 S&H Total: $50.00 $50.00 Implant Pass-through: Auto Invoice Pricing (AIP)

I am having a really tought time trying to figure this out and have posted to several boards but no one has been able to help me figure it out. I might just create a separate macro to write to a separte sheet and combine after the fact.

**tinamiller1** · 08-22-2013, 05:35 PM

Someone tried to help me but the answer does not work. I have 301 sheets in a workbook and need to copy certain cells using a macro to a single sheet. The macro works great when I comment out the portion that copies a summation cell. That cell happens to be j43 on every sheet. You will see below the altered code based on input from this board, however it does not copy right. It will cause the other items that are being copy and pasted to not copy right. None of the other cells are summation cells. They are simply the value in that particular cell. If this will not work due to variations of the cells, I can create a separate macro to copy and paste b8, b9, b5, h48 and the summation cell j43. cell b8, b9, b5 happen to be the claim number, the mpin and the date of service. j43 is the summation of the charges. I need this information so I can make sure that my copy and paste worked correctly.

Code:

'seventh macro
'copy cells
Sub copycells()
Dim WS As Worksheet, wsum As Worksheet
Dim wb As Workbook
Dim vws As Variant 'Need to use a Variant for iterator
Dim i As Integer, j As String, k As String

i = 0
Set wb = Workbooks("sheet4.xlsm")
Set wsum = wb.Sheets("summary")

'Iterate through the sheets
For Each vws In wb.Sheets
If vws.Name <> "summary" Then
j = CStr(i + 2)
k = CStr(i + 18)
vws.Range("b8").Copy wsum.Range("a" & j)
vws.Range("b9").Copy wsum.Range("b" & j)
vws.Range("b5").Copy wsum.Range("c" & j)
vws.Range("H48").Copy wsum.Range("D" & j)
vws.Range("g13:g31").Copy wsum.Range("e" & j & ":e" & k)
vws.Range("i13:i31").Copy wsum.Range("f" & j & ":f" & k)
vws.Range("j13:j31").Copy wsum.Range("g" & j & ":g" & k)
vws.Range("k13:k31").Copy wsum.Range("h" & j & ":h" & k)
vws.Range("l13:l31").Copy wsum.Range("i" & j & ":i" & k)
vws.Range("k38").Copy wsum.Range("j" & j)
vws.Range("l38").Copy wsum.Range("k" & j)
vws.Range("e2").Copy wsum.Range("l" & j)
Sheets("Sheet4").Range("j43").Copy
Sheets("summary").Range("m" & j).PasteSpecial Paste:=xlPasteValues


i = i + 18
End If
Next
End Sub

I am going to attach what this macro outputs that is wrong and what it looks like when I comment out the 2 lines that begin with sheets, which does work as you will see. Example1 is output of macro and example2 is the sheet that has the data. Remember there are 301 of these sheets with various data but same layout.

**patel** · 08-22-2013, 10:58 PM

1) why you attached xlsx file and not xlsm with macro ?
2) wher'is the sheet Summary ?

**tinamiller1** · 08-23-2013, 12:14 AM

The code is in the sheet. I can create a new. I have to be careful of what I attach due to the nature of my job. So, I had to create a blank worksheet with examples. I don't want to get into trouble if something gets posted that I am not to post.

**Excel Fox** · 08-23-2013, 12:35 AM

But why are you using

Code:

Sheets("Sheet4").Range("j43").Copy

when you should actually be using

Code:

vws.Range("j43").Copy

**bakerman** · 08-23-2013, 06:27 AM

No need to post your question multiple times. Thread will be closed.
Please continue here

**Excel Fox** · 08-23-2013, 07:37 AM

tinamiller1, I've merged both the threads. As mentioned by bakerman, you don't have to start multiple threads for the same topic. In addition, to wrap codes, please use square brackets like so [Code] [/Co de] without the space. This is clearly mentioned in the top portion of this editor. Please follow them. I've corrected two posts.

**tinamiller1** · 08-23-2013, 04:25 PM

I have asked multiple times how to get help with some code and the fix has not been correct. I played around and got it correct and wanted to post the code here incase someone else needs help.

When you have multiple sheets in workbook and you want to copy and paste multiple cells that are in varied locations within the sheets, and then one or more cell has a summation and you need to copy/paste special, this will help:

Code:

'seventh macro
'copy cells
Sub copycells()
Dim ws As Worksheet, wsum As Worksheet
Dim wb As Workbook
Dim vws As Variant 'Need to use a Variant for iterator
Dim i As Integer, j As String, k As String

i = 0
Set wb = Workbooks("sheet1.xlsm")
Set wsum = wb.Sheets("sum")

'Iterate through the sheets
For Each vws In wb.Sheets
If vws.Name <> "sum" Then
j = CStr(i + 2)
k = CStr(i + 20)
vws.Range("b8").Copy wsum.Range("a" & j)
vws.Range("b5").Copy wsum.Range("b" & j)
vws.Range("b9").Copy wsum.Range("c" & j)
vws.Range("H43").Copy wsum.Range("D" & j)
vws.Range("a13:a27").Copy wsum.Range("e" & j & ":e" & k)
vws.Range("f13:f27").Copy wsum.Range("f" & j & ":f" & k)
vws.Range("h13:h27").Copy wsum.Range("g" & j & ":g" & k)
vws.Range("i13:i27").Copy wsum.Range("h" & j & ":h" & k)
vws.Range("j13:j27").Copy wsum.Range("i" & j & ":i" & k)
vws.Range("h34").Copy wsum.Range("j" & j)
vws.Range("j34").Copy wsum.Range("k" & j)
vws.Range("d2").Copy wsum.Range("l" & j)
vws.Range("h38").Copy
wsum.Range("m" & j).PasteSpecial (xlPasteValues)
i = i + 20
End If
Next
End Sub

The code that copies cell h38, must be separated. That code cannot be on a single line and work. I have multiple workbooks I need to utilize this code for and the cells do change. For instance, 1 workbook the summation is cell j43. I hope this will help others.