I have this code where it loops through all the sheets in the workbook and copies the value in F9 of each sheet and pastes it in "Summary" sheet column A. How can I also print the sheet name in column B? So the value is next to the sheet name in the "Summary" sheet.
code:
Sub loopsheet()
Dim wks As Worksheet
For Each wks In ThisWorkbook.Worksheets
If Not wks.Name = "Summary" Then
wks.Range("F9:F" & wks.Cells(Rows.Count, "F").End(xlUp).Row).Copy _
Destination:=Worksheets("Summary").Cells(Rows.Count, "A").End(xlUp).Offset(1)
End If
Next
End Sub
Thank you
Create two variables to track the last rows of your sheets as you loop. This will help with readability in your code. The combination of these two variables can also help you deduce the size of the range where you need to drop your sheet name.
I believe cLR + pLR - 11 is the size of range. The offset is due to headers, LR offset, and the fact that you are starting your copy from the 9th row. After you run this, you may need to tweak it up or down one if i'm wrong.
Option Explicit
Sub LoopSheet()
Dim ws As Worksheet
Dim Summary As Worksheet: Set Summary = ThisWorkbook.Sheets("Summary")
Dim cLR As Long, pLR As Long
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> Summary.Name Then
cLR = ws.Range("F" & ws.Rows.Count).End(xlUp).Row
pLR = Summary.Range("A" & Summary.Rows.Count).End(xlUp).Offset(1).Row
ws.Range("F9:F" & cLR).Copy Summary.Range("A" & pLR)
Summary.Range(Summary.Cells(pLR, 2), Summary.Cells(cLR + pLR - 11, 2)).Value = ws.Name
End If
Next ws
End Sub
Related
Need help with my code please. I want to search all worksheets in a workbook that contain a specific string in its sheet name to copy cell data of a range and paste as values into a different ws. I keep getting Run-Time error '9' subscript out of range. It highlights Set wsSumm = ThisWorkbook.Sheets("Summary") as the reasoning. I have a Summary tab so I am unsure why it is giving this error.
What I ultimately need to do is take data from A2 of all BL ws and paste into Column A of Summary ws. Then take A1 of all SL ws and paste into Column B of Summary ws. I would need to paste as values. My sheets are named 1-15 as BL, SL (BL1, SL1, BL2, SL2, BL3, SL3, ect) and a Summary ws. Below is what my Workbook looks like and the Code I am using.
[enter image description here][1]
Option Explicit
Sub Macro1()
Dim wsSumm As Worksheet, ws As Worksheet
Dim strCol As String
Dim lngRow As Long
Application.ScreenUpdating = False
Set wsSumm = ThisWorkbook.Sheets("Summary") '<-Sheet name for the data to be concolidated. Change to suit.
For Each ws In ThisWorkbook.Sheets
If ws.Name <> wsSumm.Name Then
strCol = IIf(StrConv(Left(ws.Name, 2), vbUpperCase) = "BL", "A", "B")
lngRow = IIf(StrConv(Left(ws.Name, 2), vbUpperCase) = "BL", 2, 1)
wsSumm.Range(strCol & Rows.Count).End(xlUp).Offset(1, 0).Value = ws.Range("A" & lngRow)
End If
Next ws
Application.ScreenUpdating = True
End Sub
I have a report I receive once a week with multiple data blocks that have dynamic rows and columns and each data block has a static title that will never change that are separated by a blank row. I am trying to copy these blocks into sheets based off of these titles.
I have a script that is creating the sheets and blank rows between data blocks with Python. But I am hoping to do the rest with VBA. Here is the end result Example.
Currently each of those sheets are blank, and I want to either copy paste or cut and paste the blocks into those sheets without their titles. i.e. A41:C46 into the Unanswered Service Level sheet.
Sub FormatExcel()
Dim LR As Long, i As Long
With Sheets("Master")
LR = .Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To LR
With .Range("A" & i)
If .Value = "All Call Distribution by Queue" Then
ActiveCell.CurrentRegion.Select
Selection.Copy
Sheets("All Calls by Queue").Select
ActiveSheet.Paste
End If
End With
Next
End With
End Sub
This is what I have so far.
It will copy/paste into the designated sheet. But I'm stuck on why it's adding a second blank row at the top and how to code it so that if the sheet doesn't exist then nothing will happen. I am very new to VBA but I pieced this together from other code and just recording macros. Otherwise I was just going to copy and paste this code 15 times just with different sheet titles and .Values
You can use an approach like this:
Sub FormatExcel()
Dim ws As Worksheet, wb As Workbook
Set wb = ThisWorkbook 'ActiveWorkbook?
Set ws = wb.Worksheets("Master")
CopyBlock ws, "All Call Distribution by Queue", "All Calls by Queue"
CopyBlock ws, "Title2", "Title2 sheet"
'etc etc
End Sub
Sub CopyBlock(ws As Worksheet, title As String, destWS As String)
Dim f As Range, rng As Range, wsDest As Worksheet
'check if destination worksheet is present
On Error Resume Next 'ignore any error
Set wsDest = ws.Parent.Worksheets(destWS) 'check in same workbook as `ws`
On Error GoTo 0 'stop ignoring errors
If wsDest Is Nothing Then
Debug.Print "Missing sheet '" & destWS; "' in workbook '" & ws.Parent.Name & "'"
Exit Sub
End If
Set f = ws.Columns("A").Find(what:=title, lookat:=xlWhole) 'search header
If Not f Is Nothing Then 'got a match?
Set rng = f.CurrentRegion
Set rng = rng.Offset(1, 0).Resize(rng.Rows.Count - 1) 'exclude header row
rng.Copy wsDest.Range("A1") 'copy to specific location
End If
End Sub
I have a workbook with multiple sheets ,the number of sheets can change for each project but they all end with PAF. The table is the same across all sheets as well as the cells.
I have a summary tab with the exact same table, I just need to sum it all up there, the table has at least 6 columns and 20 rows so each cell would need the same formula (basically) so I came up with the following but I'm getting an error. Any suggestions?
Sub SumPAF
Dim ws as Worksheet
Sheets("Summary PAF").Activate
For Each ws In ActiveWorkbook.Worksheets
If ws.Name Like "PAF" Then
Range("E10") = WorksheetFunction.Sum(Range("E10"))
End If
Next
End Sub
It's getting stuck in "For Each" saying that an Object is required...
I have commented the code so you should not have a problem understanding it.
Option Explicit
Sub SumPAF()
Dim ws As Worksheet
'~~> This will store the cell addresses
Dim sumFormula As String
'~~> Loop though each worksheet and check if it ends with PAF
'~~> and also to ingore summary worksheet
For Each ws In ActiveWorkbook.Worksheets
If UCase(ws.Name) Like "*PAF" And _
InStr(1, ws.Name, "Summary", vbTextCompare) = 0 Then _
sumFormula = sumFormula & "," & "'" & ws.Name & "'!E10"
'~~> or simply
'sumFormula = sumFormula & ",'" & ws.Name & "'!E10"
Next
'~~> Remove the intital ","
sumFormula = Mid(sumFormula, 2)
'~~> Insert the sum formula
If sumFormula <> "" Then _
Sheets("Summary PAF").Range("E10").Formula = "=SUM(" & sumFormula & ")"
End Sub
Here's a very simple and easy to understand program to illustrate how VBA can be used for loops over ranges. If you have any questions, feel free to ask:
Sub SumPAF()
'Save a reference to the Summary Sheet
Dim SummarySheet As Worksheet
Set SummarySheet = Sheets("Summary PAF")
'Save a reference to the Summary Table and decide the table dimensions
Dim SummaryTable As Range
Set SummaryTable = SummarySheet.Range("A1:F20")
'Create an array to save the sum values
Dim SumValues() As Double
ReDim SumValues(1 To SummaryTable.Rows.Count, 1 To SummaryTable.Columns.Count)
'Loop through the workbook sheets
Dim ws As Worksheet, TableRange As Range
For Each ws In ActiveWorkbook.Worksheets
'Find sheets ending in PAF other than the summary PAF
If ws.Name Like "*PAF" And Not ws.Name = SummarySheet.Name Then
'create a reference to a range on the sheet in the same place and dimensions as the summary table
Set TableRange = ws.Range(SummaryTable.Address)
'loop through the range, cell by cell
Dim i As Long, j As Long
For i = 1 To TableRange.Rows.Count
For j = 1 To TableRange.Columns.Count
'Sum each cell value into the array, where its cell address is the array coordinates.
SumValues(i, j) = SumValues(i, j) + TableRange.Cells(i, j).Value
Next j
Next i
End If
Next
'Output the array into the summary table
SummaryTable.Value = SumValues
End Sub
Hi I'm looking to create code for copying certain columns (AH to AX) across all worksheets then skipping worksheets named "Aggregated" & "Collated Results"
I have this already
Sub FillSheets()
Dim ws As Worksheets
Dim worksheetsToSkip As Variant
Dim rng As Range
Dim sh As Sheet1
Set rng = sh.Range("AH1:AX7200")
worksheetsToSkip = Array("Aggregated", "Collated Results")
For Each ws In Worksheets
If IsError(Application.Match(ws.Name, worksheetsToSkip, 0)) Then
End Sub
This will
Loop through sheets
"Copy" data from AH1 - AX1 down to the last used row that is determined by Column AH (Update column if needed)
"Paste" data on a sheet named Sheet1 (Update if needed). The data will be pasted in Column AH on the first available blank row. It's not clear what column you want to paste the data in. You just need to change AH to Some Column to modify
"Copy" and "Paste" are in quotes because we are really just transferring values here since this is quicker. We are actually setting the values of two equal sized ranges equal to each other.
Option Explicit
Sub AH_AX()
'Update "Sheet1" to sheet where data is being pasted
Dim ms As Worksheet: Set ms = ThisWorkbook.Sheets("Sheet1")
Dim ws As Worksheet, wsLR As Long, msLR As Long
Dim CopyRange As Range, PasteRange As Range
For Each ws In Worksheets
If ws.Name <> "Aggregated" And ws.Name <> "Collated Results" Then
'Determine last rows
wsLR = ws.Range("AH" & ws.Rows.Count).End(xlUp).Row
msLR = ms.Range("AH" & ms.Rows.Count).End(xlUp).Offset(1).Row
'Set Ranges
Set CopyRange = ws.Range("AH1:AX" & LR)
Set PasteRange = ms.Range("AH" & msLR).Resize(CopyRange.Rows.Count, CopyRange.Columns.Count)
'Value Transfer (Quicker than copy/paste)
PasteRange.Value = CopyRange.Value
End If
Next ws
End Sub
Okay, so here goes. I have a workbook with individual worksheets for each day detailing the stock trading activity. I also currently have a VBA which provides a sum total for specified columns on each of these worksheets, and this works fine.
However, what I would like to do is add to my VBA so that it provides a sum total for these columns into the master worksheet.
So, for example: If there was trading activity totalling 4m on the 1st Oct 2018 on worksheet 1, and trading activity totalling 3m on 2nd october 2018 on worksheet 2, I would like to have this total of 7m shown on the master worksheet.
I've attached my current vba below, the column currently being summed on each individual worksheet is J. The columns summed on the individual worksheet do not change, however the amount of data contained in those columns obviously does depending on trading activity.
Sub autoSum_AllSheets()
Dim ws As Worksheet
Dim cel1 As String, cel2 As String
Dim firstCel As Range
For Each ws In ActiveWorkbook.Worksheets
With ws
Set firstCel = .Range("J3").End(xlDown).Offset(2, 0)
cel1 = firstCel.Offset(-2, 0).End(xlUp).Address
cel2 = firstCel.Offset(-1).Address
firstCel.Value = "=SUM(" & cel1 & ":" & cel2 & ")"
End With
Next ws
End Sub
I've also attached a screenshot of a current mock worksheet taken from a random day, with the sum total i get after running the vba bolded and highlighted in red.
Any advice on how to approach this would be great as I'm a newcomer to all things VBA.
Edit: I've attached a mock screenshot of what I'm trying to achieve on the master worksheet below:
I recommend the following …
Option Explicit
Public Sub AutoSumAllWorkheets()
Const MasterName As String = "Master" 'specify name of master sheet
Dim wsMaster As Worksheet
On Error Resume Next 'test if master exists
Set wsMaster = ActiveWorkbook.Worksheets(MasterName)
On Error GoTo 0
If wsMaster Is Nothing Then 'add master if not exists
Set wsMaster = ActiveWorkbook.Worksheets.Add(Before:=ActiveWorkbook.Worksheets(1))
wsMaster.Name = MasterName
'instead you can throw a message and exit here
'MsgBox "No master found"
'Exit Sub
End If
Dim FirstCell As Range, LastCell As Range
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
With ws
If .Name <> MasterName Then 'don't sum on master sheet
Set FirstCell = .Range("J3")
Set LastCell = FirstCell.End(xlDown)
LastCell.Offset(2, 0).Formula = "=SUM(" & FirstCell.Address & ":" & LastCell.Address & ")"
'write in master
With wsMaster.Cells(wsMaster.Rows.Count, "A").End(xlUp)
.Offset(1, 0).Value = ws.Name
.Offset(1, 1).Formula = "=" & LastCell.Offset(2, 0).Address(External:=True)
End With
End If
End With
Next ws
'sum all sheets up
With wsMaster.Cells(wsMaster.Rows.Count, "A").End(xlUp)
.Offset(2, 0).Value = "Total sum:"
.Offset(2, 1).Formula = "=SUM(" & wsMaster.Cells(1, "B").Address & ":" & .Offset(0, 1).Address & ")"
End With
End Sub
The first part checks if a master sheet exists and adds one if it doesn't exist.
Then I improved your code a bit:
I recommend to use clear variable names (makes it easier). For example your firstCel actually was not the first but the sum cell. That is very confusing and you will easily fail.
Use .Formula to write a formula.
I added some code to write the sums of each sheet into the master sheet. Note that this appends the entries at the master sheet. So if you run it twice you need to clear the entries in the master sheet first.
If you want to write into another column of the master sheet just change the column name of wsMaster.Cells(wsMaster.Rows.Count, "A").End(xlUp) from "A" to eg "L"
Try:
Sub test4()
Dim ws As Worksheet
Dim LastRowJ As Long
Dim MasterTotal As Double
For Each ws In ActiveWorkbook.Worksheets
LastRowJ = ws.Cells(ws.Rows.Count, "J").End(xlUp).Row
MasterTotal = MasterTotal + ws.Range("J" & LastRowJ).Value '<= Let us assume that total appears in each sheet at the last line in column J
Next ws
Sheet1.Range("A1").Value = MasterTotal '<= Change where you want to import the total of totals
End Sub