PDA

View Full Version : [SOLVED] Summing of sheets macro needed.



rdelosh74
07-10-2014, 10:28 AM
Ok, I am unsure how to go about this or what type of macro I need. But here is what I need for an end result. (You'll have to open the "before" file to read along).

In a workbook. Starting on sheet 5 going to the last sheet in the workbook. Can be just sheet 5. Or 5 through 55. It's variable.

Column F (starting on row 4). If there is a value in that column.
Then to copy Columns D, E, F, L, P, Q, R, T, U and V (from that row) to a new sheet (Totals) at the end of the workbook for that row.

If there is a "X" in Column B of that same row then do not copy the information from that row.

As the macro works its way down the sheet, if in the new (Totals) sheet, there is a duplicate (using the information in Column D as the column that is checked)
Sum all Column's T with T, U with U, and V with V.

Totals tab is included in example file. (Note) At the beginning of the macro, the totals tab does not exist.

Then, anything that is in Column A in the Totals Sheet. That has a letter in it. Excluding the letters W, R, or NN. Needs the entire row deleted.

If anyone can get this, thank you so much. 11924

p45cal
07-11-2014, 02:26 PM
Cross post: http://www.excelforum.com/excel-programming-vba-macros/1021734-summing-of-sheets-macro-needed.html
rdelosh74, please read: http://www.excelguru.ca/content.php?184-A-message-to-forum-cross-posters


try:
Sub blah()
Dim TotalsSht As Worksheet, SamePartNameInTotals As Range
StrSheetsToIgnore = "Sheet1,Sheet2,Sheet3,Sheet4,Totals"
On Error Resume Next
Set TotalsSht = Sheets("Totals")
On Error GoTo 0
If TotalsSht Is Nothing Then
Set TotalsSht = Sheets.Add(After:=Sheets(Sheets.Count))
TotalsSht.Name = "Totals"
End If
For Each sht In ThisWorkbook.Sheets
If InStr(StrSheetsToIgnore, sht.Name) = 0 Then
With sht
For Each cll In .Range(.Cells(.Rows.Count, "D").End(xlUp), .Range("D4"))
If Len(cll.Value) > 0 And Len(cll.Offset(, 2).Value) > 0 And UCase(cll.Offset(, -2).Value) <> "X" Then
Set SamePartNameInTotals = Sheets("Totals").Columns(1).Find(what:=cll.Value, LookIn:=xlFormulas, lookat:=xlWhole, searchformat:=False)
If SamePartNameInTotals Is Nothing Then
'copy row data:
Set Destn = TotalsSht.Cells(TotalsSht.Rows.Count, "A").End(xlUp).Offset(1)
cll.Range("$A$1:$C$1,$I$1,$M$1:$O$1,$Q$1:$S$1").Copy Destn
Else 'add to totals:
With SamePartNameInTotals
cll.Offset(, 16).Resize(, 3).Copy
.Offset(, 7).Resize(, 3).PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd
End With
End If
End If
Next cll
End With
End If
Next sht
DeleteTotalsRows TotalsSht
End Sub



Sub DeleteTotalsRows(TheSheet As Worksheet)
'why can't these rows be excluded by not copying them over in the first place?
Dim RowsToDelete As Range
For Each cll In TheSheet.UsedRange.Columns(1).Cells
If cll.Value Like "*[A-Z]*" Then
If (InStr(1, cll.Value, "W", vbTextCompare) + InStr(1, cll.Value, "R", vbTextCompare) + InStr(1, cll.Value, "NN", vbTextCompare)) = 0 Then
If RowsToDelete Is Nothing Then Set RowsToDelete = cll Else Set RowsToDelete = Union(RowsToDelete, cll)
End If
End If
Next cll
RowsToDelete.EntireRow.Select 'delete this line and replace it by removing the apostrophe from the commented-out line below if the selected rows are correct for deletion.
'RowsToDelete.EntireRow.Delete
End Sub
The same code is in the attached.

rdelosh74
07-14-2014, 08:58 AM
The first sub did not work as nothing was copied over to the new sheet. Though your question about copying over the unneeded rows in the first place has made me re-evaluate the flow I was going for and that is now back on the drawing board with a simpler direction. Thank you for the help.

p45cal
07-14-2014, 09:24 AM
The first sub did not work as nothing was copied over to the new sheet.I see the file I attached in Msg#2 is showing 0 views. The macro works in this file and it is just a copy of your file.
Also, I just now tried copying the macro in my message into your file in Msg#1 and running it and it copied stuff over, you might want to delete any sheet called Totals before you run it to avoid confusion.

rdelosh74
07-14-2014, 10:05 AM
11951

Your right. For some reason the copy paste version didn't work correctly. The macro does work. Sorry, still learning big time. Know just enough to make myself dangerous.

With your previous suggestion though. Could we change the needs to the below:

In a workbook. Starting on sheet 5 going to the last sheet in the workbook. Can be just sheet 5. Or 5 through 55. It's variable.

Column T, U or V. If there is a value in any of those cells.

Then copy Columns D, E, F, L, P, Q, R, T, U and V (from that row) to a new sheet (Totals) at the end of the workbook for that row.

Anything that is in Column D. That has a letter in it. Excluding the letters W, R, WNN or NN. Does not copy over to the totals sheet.

As the macro works its way down the sheet, if in the new (Totals) sheet, there is a duplicate (using the information in Column D as the column that is checked)
Sum all Column's T with T, U with U, and V with V.

Totals tab is included in example file. (Note) At the beginning of the macro, the totals tab does not exist.

Thanks and sorry for the backtracking.

p45cal
07-14-2014, 10:53 AM
Sub blah2()
Dim TotalsSht As Worksheet, SamePartNameInTotals As Range
StrSheetsToIgnore = "Serial Number Run Sheet ,Teardown Ticket,Eproms,qry_BOMCOMPARE_FINAL_OUTPUT,Totals," 'note there IS a space after the first sheet's name! This matters.
On Error Resume Next
Set TotalsSht = Sheets("Totals")
On Error GoTo 0
If TotalsSht Is Nothing Then
Set TotalsSht = Sheets.Add(After:=Sheets(Sheets.Count))
TotalsSht.Name = "Totals"
End If
For Each sht In ThisWorkbook.Sheets
If InStr(StrSheetsToIgnore, sht.Name) = 0 Then
With sht
For Each cll In .Range(.Cells(.Rows.Count, "D").End(xlUp), .Range("D4"))
If Len(cll.Value) > 0 And Len(cll.Offset(, 2).Value) > 0 And UCase(cll.Offset(, -2).Value) <> "X" Then
If Not (cll.Value Like "*[A-Z]*" And (InStr(1, cll.Value, "W", vbTextCompare) + InStr(1, cll.Value, "R", vbTextCompare) + InStr(1, cll.Value, "NN", vbTextCompare)) = 0) Then
Set SamePartNameInTotals = Sheets("Totals").Columns(1).Find(what:=cll.Value, LookIn:=xlFormulas, lookat:=xlWhole, searchformat:=False)
If SamePartNameInTotals Is Nothing Then
'copy row data:
Set Destn = TotalsSht.Cells(TotalsSht.Rows.Count, "A").End(xlUp).Offset(1)
cll.Range("$A$1:$C$1,$I$1,$M$1:$O$1,$Q$1:$S$1").Copy Destn
Else 'add to totals:
With SamePartNameInTotals
cll.Offset(, 16).Resize(, 3).Copy
.Offset(, 7).Resize(, 3).PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd
End With
End If
End If
End If
Next cll
End With
End If
Next sht
End Sub

rdelosh74
07-21-2014, 07:25 AM
This mostly works. In the sample file I sent here is the output I get:















65926091
in
2
1



-2
2



40820800
column
1
2
40820700



2



69515600
would
1
2




2



68826100
a
1
1




2



60307190W
part
1
1
60322690W
60309390W


1
1


66200900

1
1





2


61971890W

1
1




1
1


62590391W

1
2



-2
2



50062600

1
2





2


13805900W

1
M.



-2
2



61905905W

1
1








60860702W

1
1
60860701W
60860700W


2



28913501

2
1




2
2


60212800W

1
1




2



FI014MMTWZ00102

1









61981990W

1
1




2



91161301

1
1




2



R

1









W

1









68539800

1
2.1








91427200

1
2








69511200

1
2








75438700W

2
2








62313200W

1
2








62311602W

1
2








85081600

1
M.
85068900




2


96499809

1






2


94678500

1









94678600

1









80005990

1
3








63324600

1
3








36536901NN

1
2








68725100NN

1
3








26103400

1
1










On some of the copied over rows there is no value in the last 3 columns (originally T,U,V from the previous spreadsheets). Where on the totals sheet, there should only be rows that have values in those cells.

Also, is there a way to make this work when running it from another sheet (a macro sheet). Currently it only works when the macro is in the same sheet.

Thank you for all the help on this.

p45cal
07-21-2014, 09:15 AM
On some of the copied over rows there is no value in the last 3 columns (originally T,U,V from the previous spreadsheets). Where on the totals sheet, there should only be rows that have values in those cells.This wasn't part of your original spec!




Also, is there a way to make this work when running it from another sheet (a macro sheet). Currently it only works when the macro is in the same sheet.I'll answer both these in one. I going to presume when you talk of a sheet you mean a workbook.
You can place the following macro in a standard code-module in the Personal workbook usually visible in the VB Editor in the Project Explorer panel on the left (Ctrl+R if you cant see the panel). Save the Personal workbook from the VBEditor when that project is the active one in the VBEditor by using the File dropdown menu.
Delete the macro from any other workbook.
Now with the workbook you want to process being the active workbook, you can Alt+F8 to reach the Macro dialogue box and making sure that you've chosen Personal.xlsb or All Open Workbooks in the Macros in: field, you should be able to select and run 'Personal.xlsb!'blah2.

Here's the code:
Sub blah2()
Set Awb = ActiveWorkbook
With Awb
Dim TotalsSht As Worksheet, SamePartNameInTotals As Range
StrSheetsToIgnore = "Serial Number Run Sheet ,Teardown Ticket,Eproms,qry_BOMCOMPARE_FINAL_OUTPUT,Totals,TotalsOrig" 'note there IS a space after the first sheet's name! This matters.
On Error Resume Next
Set TotalsSht = .Sheets("Totals")
On Error GoTo 0
If TotalsSht Is Nothing Then
Set TotalsSht = .Sheets.Add(After:=.Sheets(.Sheets.Count))
TotalsSht.Name = "Totals"
Else
myResponse = MsgBox("You already have a pre-existing sheet called Totals in " & vbLf & "this workbook, if you continue to run this macro " & vbLf & "it may add values to columns H, I and J and this may not be correct." & vbLf & vbLf & "Click Cancel to abort, OK to continue running.", vbOKCancel + vbCritical + vbDefaultButton2)
If myResponse = vbCancel Then
MsgBox "Aborted"
Exit Sub
End If
End If
For Each sht In Awb.Sheets
If InStr(StrSheetsToIgnore, sht.Name) = 0 Then
With sht
For Each cll In .Range(.Cells(.Rows.Count, "D").End(xlUp), .Range("D4"))
If Len(cll.Value) > 0 And Len(cll.Offset(, 2).Value) > 0 And UCase(cll.Offset(, -2).Value) <> "X" Then
If Not (cll.Value Like "*[A-Z]*" And (InStr(1, cll.Value, "W", vbTextCompare) + InStr(1, cll.Value, "R", vbTextCompare) + InStr(1, cll.Value, "NN", vbTextCompare)) = 0) And Application.CountA(cll.Offset(, 16).Resize(, 3)) > 0 Then
Set SamePartNameInTotals = Sheets("Totals").Columns(1).Find(what:=cll.Value, LookIn:=xlFormulas, lookat:=xlWhole, searchformat:=False)
If SamePartNameInTotals Is Nothing Then
'copy row data:
Set Destn = TotalsSht.Cells(TotalsSht.Rows.Count, "A").End(xlUp).Offset(1)
cll.Range("$A$1:$C$1,$I$1,$M$1:$O$1,$Q$1:$S$1").Copy Destn
Else 'add to totals:
With SamePartNameInTotals
cll.Offset(, 16).Resize(, 3).Copy
.Offset(, 7).Resize(, 3).PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd
End With
End If
End If
End If
Next cll
End With
End If
Next sht
Application.CutCopyMode = False
End With
End Sub

rdelosh74
07-21-2014, 09:58 AM
Perfect! Thank you so much.