Need to summarize data from multiple excel worksheets onto one summary page - vba

I'm trying to create a yearly summary for some of our transfers. Essentially, I have 12 sheets, one for each month of the year, and each entry is given one of four specific "Transfer Rationales" in column L. I need to be able to create a worksheet that gives me a running year-to-date summary based on each transfer rationale.
So say, for example, the transfer rationale I'm looking at is called "Incorrectly Assigned" - I think need to have the summary page show columns G-K of each row where column L is "Incorrectly Assigned" from all twelve month sheets.
I've been looking at VBA code and trying to tweak some to work, but I could use some help!
EDIT:
Obviously it's not working as I need or I wouldn't be here, but I don't have much knowledge about VBA. I have something here where the code is grabbing the entries where column L met the criteria, but it was
a) copying all the columns, and I only need G-K to paste, and
b) was putting the copied rows all in one row in the summary tab, so I could see the data for a split second, and then it would overwrite with the next line and so on until it finally settled on the last entry found.
SECOND EDIT:
So I have a code that now (mostly) works, I've pasted it below and deleted the old code above.
Private Sub CommandButton1_Click()
Dim WkSht As Worksheet
Dim r As Integer
Dim i As Integer
i = 1
For Each WkSht In ThisWorkbook.Worksheets
i = i + 1
If WkSht.Name <> "Incorrectly Assigned" Then
For r = 1 To 1000
If WkSht.Range("L" & r).Value = Sheets("Incorrectly Assigned").Range("A1").Value Then
WkSht.Range("E:L").Rows(r & ":" & r).Copy
Sheets("Incorrectly Assigned").Range("E:L").End(xlUp).Offset(i, 0).PasteSpecial Paste:=xlPasteValues
End If
Next r
End If
Next WkSht
End Sub
The problem now is that it is only grabbing the last match from each worksheet - so say January has four matching entries, it's only pasting the fourth entry, then the next row down it'll paste the last entry from February etc. and then if there's an entry in say November that matches, it'll be pasted in the 11th row from the beginning, rather than each entry being pasted one after another.

Better to create a sub-routine that you call from your "CommandButton1". Then you can call the procedure from more than one location. You can also generalize it by using an input parameter 'transferID' which defines the summary you want.
Private Sub CommandButton1_Click()
Call PrintSummary("Incorrectly Assigned")
End Sub
It will likely need some tweaking to get it how you want, but this should give you some ideas to get you started:
Sub PrintSummary(transferID As String)
Dim ws As Excel.Worksheet
Dim wso As Excel.Worksheet
Dim lrow As Long
Dim rng As Excel.Range
Dim rngo As Excel.Range
Dim cell As Excel.Range
Dim colH As Variant
Dim i As Integer
'// Define columns for output
colH = Array("G", "H", "I", "J", "K")
'// Check for summary sheet (for output)
On Error Resume Next
Set wso = ThisWorkbook.Worksheets("Summary")
On Error GoTo 0
If wso Is Nothing Then
'// Summary worksheet does not exist :/
Exit Sub
Else '// format worksheet for output
'// for example...
wso.Cells.Delete Shift:=xlUp
Set rngo = wso.Range("A1") '// define output start
Set wso = Nothing
End If
'// Loop through worksheets
For Each ws In ThisWorkbook.Worksheets
'// Check for valid worksheet name
Select Case VBA.UCase(ws.Name)
Case "JAN", "FEB" '// and so forth...
Set rng = ws.Range("L1")
Set rng = ws.Range(rng, ws.Cells(Rows.Count, rng.Column).End(xlUp))
For Each cell In rng
If (VBA.UCase(cell.Text) = VBA.UCase(transferID)) Then
'// Print meta data
rngo.Offset(lrow, 0).Value = ws.Name
rngo.Offset(lrow, 1).Value = transferID
'// Print values
For i = 0 To UBound(colH)
rngo.Offset(lrow, i + 2).Value = ws.Cells(cell.Row, VBA.CStr(colH(i))).Value
Next i
'// Update counter
lrow = lrow + 1
End If
Next cell
Case Else
'// Not a month? do nothing
End Select
Next ws
End Sub

You do not need VBA - just refence the cell in the other tab:
SheetName!CellAddress
Precede the cell address with the worksheet name, and follow it with an exclamation point.
If you need VBA, then I have understood your question incorrectly.
EDIT:
Lets start with problem B:
was putting the copied rows all in one row in the summary tab
Lets look at the code you use to paste values:
Sheets("Summary").Range("A65536").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Here you always paste everyting in the same place, in cell A65536 which you offset by one. On every iteration of your loop, the values will be at the same place. Change the Offset(1) to
Offset(0, r)
Now on every iteration you will paste on a different row, because r will be 1, 2, ..., 1000. See MSDN for documentation on Offset. Select a values that accomplished a paste the way you need.
Lets go to the next question:
a) it was copying all the columns
I will edit once the first part works as it should for you.

Related

Select cells between bold cells using a loop

I am working with data where the only consistency is the layout and the bold headings to distinguish between a new date.
I am trying to find the cells in between these cells in bold, find the value "Individual" (in column A) in the selected rows, then sum the values of the given rows in column D (as there can be more then 1 row with "Individual"), and copy this new value to a different cell.
Since the cells between the bold is one date, if the value is not there, the output cell needs to shift down one without filling in anything.
Here is what I have so far:
Sub SelectBetween()
Dim findrow As Long, findrow2 As Long
findrow = range("A:A").Find("test1", range("A1")).Row
findrow2 = range("A:A").Find("test2", range("A" & findrow)).Row
range("A" & findrow + 1 & ":A" & findrow2 - 1).Select
Selection.Find("Individual").Activate
range("D" & (ActiveCell.Row)).Select
Selection.copy
sheets("Mix of Business").Select
range("C4").Select
ActiveSheet.Paste
Exit Sub
errhandler:
MsgBox "No Cells containing specified text found"
End Sub
How can I loop through the data and each time it loops through a range, no matter if it finds the value (e.g. individual) or not, shifts down one row on the output cell? Also, how can I change the findrow to be a format (Bold) rather then a value?
Here is some data for reference:
This is what I am trying to get it to look like:
So you have a good start to trying to work through your data. I have a few tips to share that can hopefully help get you closer. (And please come back and ask more questions as you work through it!)
First and foremost, try to avoid using Select or Activate in your code. When you look at a recorded macro, I know that's all you see. BUT that is a recording of your keystrokes and mouseclicks (selecting and activating). You can access the data in a cell or a range without it (see my example below).
In order to approach your data, your first issue is to figure out where your data set starts (which row) and where it ends. Generally, your data is between cells with BOLD data. The exception is the last data set, which just has a many blank rows (until the end of the column). So I've created a function that starts at a given row and checks each row below it to find either a BOLD cell or the end of the data.
Private Function EndRowOfDataSet(ByRef ws As Worksheet, _
ByVal startRow As Long, _
Optional maxRowsInDataSet As Long = 50) As Long
'--- checks each row below the starting row for either a BOLD cell
' or, if no BOLD cells are detected, returns the last row of data
Dim checkCell As Range
Set checkCell = ws.Cells(startRow, 1) 'assumes column "A"
Dim i As Long
For i = startRow To maxRowsInDataSet
If ws.Cells(startRow, 1).Font.Bold Then
EndRowOfDataSet = i - 1
Exit Function
End If
Next i
'--- if we make it here, we haven't found a BOLD cell, so
' find the last row of data
EndRowOfDataSet = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
End Function
To show you how to use that with your specific data, I've created a test subroutine indicating how to loop through all the different data sets:
Option Explicit
Public Sub DataBetween()
Dim thisWB As Workbook
Dim dataWS As Worksheet
Set thisWB = ThisWorkbook
Set dataWS = thisWB.Sheets("YourNameOfSheetWithData")
'--- find the first bold cell...
'Dim nextBoldCell As Range
'Set nextBoldCell = FindNextBoldInColumn(dataWS.Range("A1"))
'--- now note the start of the data and find the next bold cell
Dim startOfDataRow As Long
Dim endOfDataRow As Long
Dim lastRowOfAllData As Long
startOfDataRow = 3
lastRowOfAllData = dataWS.Cells(ws.Rows.Count, "A").End(xlUp).Row
'--- this loop is for all the data sets...
Loop
endOfDataRow = EndRowOfDataSet(dataWS, startOfDataRow)
'--- this loop is to work through one data set
For i = startOfDataRow To endOfDataRow
'--- work through each of the data rows and copy your
' data over to the other sheet here
Next i
startOfDataRow = endOfDataRow + 1
Do While endOfDataRow < lastRowOfAllData
End Sub
Use both of those together and see if that can get you closer to a full solution.
EDIT: I should have deleted that section of code. It was from an earlier concept I had that didn't completely work. I commented out those lines (for the sake of later clarity in reading the comments). Below, I'll include the function and why it didn't completely work for this situation.
So here's the function in question:
Public Function FindNextBoldInColumn(ByRef startCell As Range, _
Optional columnNumber As Long = 1) As Range
'--- beginning at the startCell row, this function check each
' lower row in the same column and stops when it encounters
' a BOLD font setting
Dim checkCell As Range
Set checkCell = startCell
Do While Not checkCell.Font.Bold
Set checkCell = checkCell.Offset(1, 0)
If checkCell.Row = checkCell.Parent.Rows.Count Then
'--- we've reached the end of the column, so
' return nothing
Set FindNextBoldInColumn = Nothing
Exit Function
End If
Loop
Set FindNextBoldInColumn = checkCell
End Function
Now, while this function works perfectly well, the situation is DOES NOT account for is the end of the last data set. In other words, a situation like this:
The function FindNextBoldInColumn will return nothing in this case and not the end of the data. So I (should have completely) deleted that function and replaced it with EndRowOfDataSet which does exactly what you need. Sorry about that.

how to copy past using VBA in excel?

Hellow,
I have a problem with copy past code
I can't identify the last cell in the row "where I would like to past" !!?
Here in the next code, I wrote "Shet.Cells(Rows.Count, "N").End(xlUp).row + 1", and it works well just in case there are no hidden rows, except that last row's value always replace itself !!
So, what should I do to update last row's value every time I execute Sub Copy_Past() ???
Sub Copy_Past()
Dim Shet As Worksheet
Set Shet = ThisWorkbook.Sheets(1)
Dim LRow As Long
'To get the latest cell in the column "N", where I would like to paste my data.
LRow = Shet.Cells(Rows.Count, "N").End(xlUp).row + 1
'To make a copy form where I selected
Selection.SpecialCells(xlCellTypeVisible).Copy ActiveSheet.Cells(LRow, "M")
'To delete the range of data that I selected and after coping them
Selection.SpecialCells(xlCellTypeVisible).Delete (xlShiftUp)
End Sub
I found a solution for this :)
I brought this method from here
https://answers.microsoft.com/en-us/msoffice/forum/msoffice_excel-msoffice_custom-mso_2007/finding-last-row-including-hidden-rows/af0d7d7c-84f1-44bf-b36a-5abc98a93fa6
Sub xlCellTypeLastCell_Example_Column()
For LastRow = Columns("N").SpecialCells(xlCellTypeLastCell).row To 1 Step -1
If Len(Cells(LastRow, "N").Formula) Then Exit For
Next
MsgBox LastRow
End Sub

how to copy cells from sheet 1 to sheet 2 without removing data on sheet 2

I need code, as my title suggests, for the following task. I already tried a lot of different code but it's still not working.
I only need to move 2 columns, "SKU" and "Discount", into sheet2 using command button and delete it right away.
I'm already okay for this coding. However, but the problem is just beginning.
When I succeed to moved the first data, and try to move the 2nd data, the 1st data disappears.
I already tried many ways but still can't figure it out what's wrong with the code.
Please check the following code:
Sub OUTGOING_GOODS()
function1
function2
clear
Range_End_Method
End Sub
Sub function1()
Sheets("Invoice Print").Range("B21:B27").Copy Destination:=Sheets("Outgoing Goods").Range("D4")
End Sub
Sub function2()
Sheets("Invoice Print").Range("D21:D27").Copy Destination:=Sheets("Outgoing Goods").Range("L4")
End Sub
Sub clear()
Range("B21:B27").clear
End Sub
I also need to change the range for input data as well. As you can see the Range is defined only from D21:D27, but I need more than row 27 just in case there is additional data inputted.
Already tried the following code:
With Worksheets("Sheet2")
LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
LastRow = .Cells(.Rows.Count, "L").End(xlUp).Row
For Each cell In Range("D4:D" & LastRow)
DestinationRow = LastRow + 1
Next
For Each cell In Range("L4:L" & LastRow)
DestinationRow = LastRow + 1
Next
End With
And
Lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 1 To InputData
Lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
For j = 1 To 3
.Cells(lastrow + 1, j).Value = InputData(i, j)
Next j
Next i
End With
This still isn't working.
Based on our discussions thus far I'd suggest the following:
Sub Outgoing_Goods_New()
'
Dim Outgoing As Worksheet 'Generally it's better to use Worksheet variables. Saves the trouble of having to re-type the sheet name each time you reference the sheet
Dim Invoice As Worksheet
Dim LastRow_Invoice As Long
Dim LastRow_Outgoing As Long
Set Outgoing = ActiveWorkbook.Worksheets("Outgoing Goods")
Set Invoice = ActiveWorkbook.Worksheets("Invoice Print")
'Find the last row of Outgoing column D that's used so we know where to paste the new set of outgoing goods
LastRow_Outgoing = Outgoing.Range("D1048576").End(xlUp).Row
'Make sure column L of Outgoing ends at the same point
If Outgoing.Range("L1048576").End(xlUp).Row > LastRow_Outgoing Then
LastRow_Outgoing = Outgoing.Range("L1048576").End(xlUp).Row
End If 'else column L's last used row is farther up the worksheet or the same row. Either way no need to update the value
'Determine how much data to copy
LastRow_Invoice = Invoice.Range("B1048576").End(xlUp).Row 'I'm assuming Column D of Invoice Print has to end at the same row. If not, use the same IF statement as above, but
'checking column D of Invoice
'Copy the data from column B
Invoice.Range("B2:B" & LastRow_Invoice).Copy
'Paste to Outgoing Goods
Outgoing.Range("B" & LastRow_Outgoing).PasteSpecial xlPasteAll
'Copy Column D of Invoice
Invoice.Range("D2:D" & LastRow_Invoice).Copy
Outgoing.Range("L" & LastRow_Outgoing).PasteSpecial xlPasteAll
'Clear the data from Invoice print
Invoice.Range("B2:B" & LastRow_Invoice).ClearContents 'Removes the Value, but leaves formatting, comments, etc. alone
End Sub
This is mostly the logic you already had, but I did some clean-up to remove ambiguities and genericize the logic a little. Also, notice that I didn't keep the separate Subs. With how little you're doing there's just not any benefit to parsing the logic, especially with none of the code being re-used.
Last, I didn't delete column D on Invoice Print assuming that the cells just held formulas that pull in new data based on the values in Column B. If that's not the case, it seems like you should add a second ClearContents to delete Column D as well, but that's not certain given the vagueness of your use case.

Select Method of Worksheet Class Failed

I have this sub in Excel 2010 which is supposed to filter through all the cells in a sheet until it finds a match to Proj No, then paste a field from this row into another field.
When I try to run the sub, it gives me an error 1004: Select Method of Worksheet Class Failed. I've marked the line where this occurs. Any assistance would be greatly appreciated.
Option Explicit
Private Sub btnNext_Click()
Dim ProjNo As String
Dim Col As String
Dim Row As String
Dim cell As Range
Unload Dialog
formWait.Show
Sheets("Sheet7").Activate
ProjNo = Worksheets("Sheet1").Range("D6").Value
Col = Cells(Rows.Count, "A").End(xlUp).Row
For Each cell In Range("A2:A" & Col) 
If cell.Value = ProjNo Then
Row = Row & cell.Row
End If
Next cell
Workbooks("Form.xlsm").Sheets("Sheet7").Range("Row, 6").Copy Destination:=Sheets("Sheet1").Range("19, 5") ‘Error
Unload formWait
End Sub
I don't know what GWP is, but I think you want to use ProjNo there. The Range property doesn't accept an argument like that. Unless you have a named range of "Row,6" which you don't because it's not a legal name, you have to supply Range with a valid range reference, like A6 or D2:D12, for example.
Also, you can't concatenate rows and use them in a Range reference to get a larger range. You would have to copy each row inside the loop, union the ranges as you go, or better yet, filter on the value that you want and copy the visible rows.
Try this:
Private Sub btnNext_Click()
With ThisWorkbook.Worksheets("Sheet7")
'filter for the project id
.Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 6).AutoFilter 1, "=" & .Range("D6").Value
'copy the visible rows
.Range("F2", .Cells(.Rows.Count, 6).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy _
ThisWorkbook.Worksheets("Sheet1").Cells(19, 5)
'get rid of the filter
.AutoFilterMode = False
End With
End Sub
There are a few confusing items in your code above, so I wanted to place them long-form here. Let's get started:
Dim Col As String
Dim Row As String
It looks like your design expects these to be of type Long rather than type String. Even if these variables were meant to be strings, I would recommend adjusting their names -- when your fellow developer attempts to review your design, he or she is likely to see names like "Col" or "Row" and think "these are numbers". Easy fix:
Dim Col As Long, Row As Long
The next issue comes up here:
Col = Cells(Rows.Count, "A").End(xlUp).Row
The structure above is a common method for identifying the last ROW, not column. (It also appears that you have switched the "A" and number, which is another easy fix). While it is perfectly acceptable syntactically to name the variable for last row "Col", human users are likely to find this confusing. Identifying the last row (and the last col, which you use in the For Each loop), as explained in fantastic detail here, would be better handled like this:
Dim SheetSeven As Worksheet, SheetOne As Worksheet
Dim LastRow As Long, LastCol As Long
Set SheetSeven = ThisWorkbook.Worksheets("Sheet7")
Set SheetOne = ThisWorkbook.Worksheets("Sheet1")
With SheetSeven
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
LastCol = .Range("A" & .Columns.Count).End(xlToLeft).Column
End With
This should make your For Each loop look like this:
With SheetSeven
For Each cell in .Range("A2:A" & LastCol)
'... do you comparison and row incrementing here
Next cell
End With
Once you've identified your sheet as a variable, the Range.Copy action should be much easier as well:
With SheetSeven
.Range(.Cells(Row, 6)).Copy _
Destination:=SheetOne.Range(SheetOne.Cells(19, 5))
End With
Also one other thing you may wish to check is the status of Application.ScreenUpdating.
With the release of Office 2013 and later, a SDI (Single Document Interface) was introduced. If Application.ScreenUpdating is False and the workbook is not active, the implied call to Workbook.Activate will fail. Check the status of ScreenUpdating and set it to True if needed. You can set it back to False after the first Activate call for that workbook is made.
See this article:
https://support.microsoft.com/en-us/help/3083825/excel-workbook-is-not-activated-when-you-run-a-macro-that-calls-the-wo
In my case the error came as the sheet was hidden.
so I check if I am not working with the hidden sheet. Or you need to unhide the sheet before you try to select or activate sheet.
For Each sh In ThisWorkbook.Sheets
If Left(sh.Name, 8) <> "Template" Then
sh.Select
sh.Range("A1").Select
End If
Next

Copy multiple rows from one worksheet to another worksheet using macro/vba

I've looked around the forum and played with various options but not found a clear match for my problem:
My task is to copy data from a worksheet (called “workorders”) to a second worksheet (called “Assignments”). The data to be copied is from the “workorders” worksheet starting at cell range “E2, P2:S2”; and also copied from each row (same range) until column “P” is empty – (the number of rows to be copied can vary each time we need to run this macro so we can’t select a standard range) . Then pasted into the “Assignments” worksheet, starting at cell “A4”. I’ve used the forum so far to successfully copy a single row of date (from row 2) – I admit that’s the easy part, and I’ve used various versions of code to achieve this.
I’ve also tried some code (which I found via watching a youtube clip and modifying http://www.youtube.com/watch?v=PyNWL0DXXtQ )to allow me to run a loop which repeats the copy process for each required row in the “workorders” worksheet and then pastes the data into the “assignments” worksheet- but this is where I am not getting it right, I think I’m along the right lines and think I’m not far off but any help would be very useful.
Code examples below (first 2 only copy first row, 3rd example is where I’ve tried to loop and copy multiple rows:
Sub CopyTest1()
' CopyTest1 Macro
'copy data from workorders sheet
'Worksheets("workorders").Range("E2,P2,Q2,R2,S2").Copy
Worksheets("workorders").Range("E2, P2:S2").Copy
'paste data to assignments sheet
'sheets("assigments dc").Range("A4").Paste
Sheets("Assigments DC").Select
Range("A4").Select
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub
Sub CopyTest2()
Sheets("workorders").Range("e2,p2,q2,r2,s2").Copy Sheets("assigments dc").Range("a4")
End Sub
Sub CopyTest3()
Dim xrow As Long
'Dim xrow As String
xrow = 2
Worksheets("workorders").Select
Dim lastrow As Long
lastrow = Cells(Rows.Count, 16).End(xlUp).Row
Do Until xrow = lastrow + 1
ActiveSheet.Cells(xrow, 16).Select
If ActiveCell.Text = Not Null Then
'Range("E2,P2,Q2,R2,S2").Copy
'Selection = Range("E2,P2,Q2,R2,S2").Copy
'Cells(xrow, 5).Copy
Cells(xrow, 5).Copy
Sheets("Assigments DC").Select
Range("A4").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets("workorders").Select
End If
xrow = xrow + 1
Loop
End Sub
Try this:
Sub LoopCopy()
Dim shWO As Worksheet, shAss As Worksheet
Dim WOLastRow As Long, Iter As Long
Dim RngToCopy As Range, RngToPaste As Range
With ThisWorkbook
Set shWO = .Sheets("Workorders") 'Modify as necessary.
Set shAss = .Sheets("Assignments") 'Modify as necessary.
End With
'Get the row index of the last populated row in column P.
'Change accordingly if you want to use another column as basis.
'Two versions of getting the last row are provided.
WOLastRow = shWO.Range("P2").End(xlDown).Row
'WOLastRow = shWO.Range("P" & Rows.Count).End(xlUp).Row
For Iter = 2 to WOLastRow
Set RngToPaste = shAss.Range("A" & (Iter + 2))
With shWO
Set RngToCopy = Union(.Range("E" & Iter), .Range("P" & Iter & ":S" & Iter))
RngToCopy.Copy RngToPaste
End With
Next Iter
End Sub
Read the comments first and test.
Let us know if this helps.
From what I see, you are only copying the cell in Column E. You could correct this by replacing Cells(xrow, 5).Copy with
Union(Sheets("workorders").Cells(xrow,5),Sheets("workorders").Range(Cells(xrow,"P"),Cells(xrow,"S")).Copy
However, using Select and Copy are not ideal. Instead, you can assign the value of the range directly:
Sheets("Assignments DC").Range("A4").Value = Union(Sheets("workorders").Cells(xrow,5),Sheets("workorders").Range(Cells(xrow,"P"),Cells(xrow,"S")).Value
More info on the Union method and why using Select is bad.
Is it even possible to run a line like this?
Worksheets("workorders").Range("E2, P2:S2").Copy
Each time I try different ways to copy/select a range which contains in my case, A3 and the range A34:C40 ("A3, A34:C40").Copy i get an error saying theres to many parameters.. Could this be because I'm running excel 2007?
Any tips or help would be greatly apreciated! :)