I'm Trying to create a program to total the amount of cells containing green and red font in column A among all the sheets in the workbook.
In the provided code below the code it counts ALL the cells containing green and red font in all the cells of the worksheets.
Please be sure to leave a comment if you can guide me in the right direction!
I also made an example google sheet of what im trying to accomplish:
https://docs.google.com/spreadsheets/d/1yLfCxaT-cIl_W77Y67xdg_ZTSQlg9X2a5vxAH4JtDpk/edit?usp=sharing
Sub Test_It()
Dim mySheet As Worksheet ' Define as worksheet if you're going to loop through sheets and none is a Graph/Chart sheet
Dim printRow As Integer ' Beware that integer it's limited to 32k rows (if you need more, use Long)
printRow = 2
For Each mySheet In ThisWorkbook.Sheets ' use the mySheet object previously defined
Range("N" & printRow).Value = "Sheet Name:"
Range("O" & printRow).Value = mySheet.Name
Range("P" & printRow).Value = "Approval:"
Range("Q" & printRow).Value = SumGreen(mySheet) ' you can pass the sheet as an object
Range("R" & printRow).Value = "Refused:"
Range("S" & printRow).Value = SumRed(mySheet)
printRow = printRow + 1
Next mySheet
End Sub
Function SumGreen(mySheet As Worksheet) As Long ' define the type the function is going to return
Dim myCell As Range
Dim counter As Long
For Each myCell In mySheet.UsedRange ' UsedRange is the range that has information
If myCell.Font.Color = RGB(112, 173, 71) Then ' 255 is red, not green, change to whatever you need
counter = counter + 1 ' change to counter + mycell.value if you have values and you want to sum them
End If
Next myCell
' Set the function to return the counter
SumGreen = counter
End Function
Function SumRed(mySheet As Worksheet) As Long ' define the type the function is going to return
Dim myCell As Range
Dim counter As Long
For Each myCell In mySheet.UsedRange ' UsedRange is the range that has information
If myCell.Font.Color = 255 Then ' 255 is red, not green, change to whatever you need
counter = counter + 1 ' change to counter + mycell.value if you have values and you want to sum them
End If
Next myCell
' Set the function to return the counter
SumRed = counter
End Function```
Cris:
Remember for next time to actually copy/paste your code in text, instead of pasting a picture.
Try this code and read the comments:
' If it's not going to return something, you can define this as a procedure (sub) and not a function
Sub Test_It()
Dim mySheet As Worksheet ' Define as worksheet if you're going to loop through sheets and none is a Graph/Chart sheet
Dim printRow As Integer ' Beware that integer it's limited to 32k rows (if you need more, use Long)
printRow = 2
For Each mySheet In ThisWorkbook.Sheets ' use the mySheet object previously defined
Range("N" & printRow).Value = "Sheet Name:"
Range("O" & printRow).Value = mySheet.Name
Range("P" & printRow).Value = "Approval:"
Range("Q" & printRow).Value = SumGreen(mySheet) ' you can pass the sheet as an object
Next mySheet
End Sub
Function SumGreen(mySheet As Worksheet) As Long ' define the type the function is going to return
Dim myCell As Range
Dim counter As Long
For Each myCell In mySheet.UsedRange ' UsedRange is the range that has information
If myCell.Font.Color = 255 Then ' 255 is red, not green, change to whatever you need
counter = counter + 1 ' change to counter + mycell.value if you have values and you want to sum them
End If
Next myCell
' Set the function to return the counter
SumGreen = counter
End Function
Related
I have managed to insert rows based on cell value for instance if A1 cell is 20, I run the macro, 20 rows appear under A1, those rows are blank right, I need the 20 new cells below A1 to be number 1 to 20 ( the number in A1) let me know if possible.
Cheers Adrien
Try this:
Sub counter()
Dim i as integer
for i = 2 to cells(1, 1) + 1
cells(i, 1) = i - 1
next i
End Sub
Insert an Integer Sequence Below a Cell
A Basic Example For the Active Sheet
Note that this doesn't insert rows, it just writes the integer sequence to the cells below A1.
Sub IntegersBelow()
With Range("A1")
.Resize(.Value).Offset(1).Value _
= .Worksheet.Evaluate("ROW(1:" & CStr(.Value) & ")")
End With
End Sub
Applied to Your Actual Use Case
Adjust the values in the constants section.
Sub InsertIntegersBelow()
' Use constants to change their values in one place instead
' of searching for them in the code (each may be used multiple times).
Const wsName As String = "Sheet1"
Const fRow As Long = 3
Const Col As String = "E"
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing the code
' Reference the worksheet ('ws').
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
' Calculate the last row ('lRow'),
' the row of the last non-empty cell in the column.
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row
' Validate the last row.
If lRow < fRow Then
MsgBox "No data in column range.", vbInformation
Exit Sub
End If
Dim cCell As Range ' Current Cell
Dim cValue As Variant ' Current Cell Value
Dim r As Long ' Current Row
For r = lRow To fRow Step -1 ' loop backwards
Set cCell = ws.Cells(r, Col) ' reference the current cell...
cValue = cCell.Value ' ... and write its value to a variable
If VarType(cValue) = vbDouble Then ' is a number
cValue = CLng(cValue) ' ensure whole number
If cValue > 0 Then ' greater than 0
' Insert the rows.
cCell.Offset(1).Resize(cValue) _
.EntireRow.Insert xlShiftDown, xlFormatFromLeftOrAbove
With cCell.Offset(1).Resize(cValue)
' Write the values.
.Value = ws.Evaluate("ROW(1:" & cValue & ")")
' Apply formatting.
.ClearFormats
.Font.Bold = True
End With
'Else ' less than or equal to zero; do nothing
End If
'Else ' is not a number
End If
Next r
MsgBox "Rows inserted.", vbInformation
End Sub
I need to sum two columns (B and C) in a dataset. The number of rows with data will vary between 1 and 17. I need to add the sums two rows beneath the last row of data (end result example in image 1).
My code worked beautifully for one dataset, but I am getting an error
Run-time error'6': Overflow
for a different dataset. What am I doing wrong?
'Units total
Windows("Final_Files.xlsb").Activate
Sheets("Revenue Summary").Select
lastrow = Worksheets("Revenue Summary").Cells(Rows.Count, 2).End(xlUp).Row
Dim a As Integer
a = 10000
For i = lastrow To 2 Step by - 1
a = a + Worksheets("Revenue Summary").Cells(i, 2).Value
Next
Worksheets("Revenue Summary").Cells(lastrow + 2, 2).Value = a
Correct End Result
You can try below sub-
Sub SumBC()
Dim sh As Worksheet
Dim lRowB As Long, lRowC As Long
Dim bSum As Double, cSum As Double
Windows("Final_Files.xlsb").Activate
Set sh = Worksheets("Revenue Summary")
lRowB = sh.Cells(sh.Rows.Count, 2).End(xlUp).Row
lRowC = sh.Cells(sh.Rows.Count, 3).End(xlUp).Row
bSum = WorksheetFunction.Sum(sh.Range("B2:B" & lRowB))
cSum = WorksheetFunction.Sum(sh.Range("C2:C" & lRowC))
sh.Cells(lRowB + 2, 2) = bSum
sh.Cells(lRowC + 2, 3) = cSum
sh.Activate
Set sh = Nothing
End Sub
Remember: If you want to run same sub multiple time then you need clear totals otherwise it will add totals again again below of last totals.
Your code is perfect but there is only one error. You have initialized variable 'a' with 10000. Change it to 0.
a = 0
then your code will be perfect.
Add Totals to Multiple Columns
If you're not OP: It is easy to test the code. Open a new workbook and insert a module. Copy the code into the module. Uncomment the Sheet1 line, and outcomment the Revenue Summary line. In worksheet Sheet1 add some numbers in columns 2 and 3 and your ready.
Run only the insertTotals procedure. The calculateSumOfRange is called when needed.
Play with the constants in insertTotals and change the values in the columns. Add text, error values, booleans to see how the code doesn't break.
The issue with Application.Sum or WorksheetFunction.Sum is that it fails when there are error values in the range. That's what the calculateSumOfRange is preventing. If there is an error value, the loop approach is used. If not, then Application.Sum is the result.
You can use the calculateSumOfRange in Excel as a UDF. Just don't include the cell where the formula is and you're OK, e.g. =calculateSumOfRange(A1:B10).
The Code
Option Explicit
Sub insertTotals()
Const FirstRow As Long = 2 ' First Row of Data
Const LastRowCol As Long = 2 ' The column where the Last Row is calculated.
Const TotalsOffset As Long = 2 ' 2 means: 'data - one empty row - totals'
Dim Cols As Variant
Cols = Array(2, 3) ' add more
'With ThisWorkbook.Worksheets("Sheet1")
With Workbooks("Final_Files.xlsb").Worksheets("Revenue Summary")
' Define Last Row ('LastRow') in Last Row Column ('LastRowCol').
Dim LastRow As Long
LastRow = .Cells(.Rows.Count, LastRowCol).End(xlUp).Row
' Define Last Row Column Range ('rng').
Dim rng As Range
Set rng = .Range(.Cells(FirstRow, LastRowCol), _
.Cells(LastRow, LastRowCol))
Dim j As Long
' Validate Columns Array ('Cols').
If LBound(Cols) <= UBound(Cols) Then
' Iterate columns in Columns Array.
For j = LBound(Cols) To UBound(Cols)
' Use 'Offset' to define the current Column Range and write
' its calculated total below it.
.Cells(LastRow + TotalsOffset, Cols(j)).Value = _
calculateSumOfRange(rng.Offset(, Cols(j) - LastRowCol))
Next j
End If
End With
End Sub
Function calculateSumOfRange(SourceRange As Range) _
As Double
' Initialize error handling.
Const ProcName As String = "calculateSumOfRange"
On Error GoTo clearError ' Turn on error trapping.
' Validate Source Range.
If SourceRange Is Nothing Then
GoTo NoRange
End If
' Calculate Sum of Range.
Dim CurrentValue As Variant
CurrentValue = Application.Sum(SourceRange)
Dim Result As Double
If Not IsError(CurrentValue) Then
Result = CurrentValue
Else
Dim Data As Variant
If SourceRange.Rows.Count > 1 Or SourceRange.Columns.Count > 1 Then
Data = SourceRange.Value
Else
ReDim Data(1, 1)
Data(1, 1) = SourceRange.Value
End If
Dim i As Long
Dim j As Long
For i = 1 To UBound(Data, 1)
For j = 1 To UBound(Data, 2)
CurrentValue = Data(i, j)
If IsNumeric(CurrentValue) And _
Not VarType(CurrentValue) = vbBoolean Then
Result = Result + CurrentValue
End If
Next j
Next i
End If
' Write result and exit.
calculateSumOfRange = Result
GoTo ProcExit
' Labels
NoRange:
Debug.Print "'" & ProcName & "': No range (Nothing)."
GoTo ProcExit
clearError:
Debug.Print "'" & ProcName & "': " & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
On Error GoTo 0 ' Turn off error trapping.
GoTo ProcExit
ProcExit:
End Function
The following code summs up all the rows under "B2" and "C2". Adapt it to your needs.
' Keep a reference to the worksheet
Dim ws as Worksheet
Set ws = Worksheets("Revenue Summary")
' This is how many rows there are.
Dim rowCount as Long
rowCount = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row-1
' This is the summation operation over each column
Dim b as Double, c as Double
b = WorksheerFunction.Sum(ws.Range("B2").Resize(rowCount,1))
c = WorksheerFunction.Sum(ws.Range("C2").Resize(rowCount,1))
' This writes the sum two cells under the last row.
ws.Range("B2").Cells(rowCount+2,1).Value = b
ws.Range("C2").Cells(rowCount+2,1).Value = c
I am trying to search for values listed in a column from multiple sheets in my excel workbook. If excel finds a match I would like it to return sheet names of the tabs that had the value.
Here is what i have done so far. I decided to start off by using one keyword to search multiple tabs, copy and paste the sheet name. The code below only paste the first resulting sheet name when there are other sheets containing the same keyword. I would like to know how i can pull the other sheet names that contain the same keyword.
I would also like to know how i can set up the keyword to use information in Column A of the Field List.
Sub FinalAppendVar()
Dim ws As Worksheet
Dim arr() As String
Keyword = "adj_veh_smart_tech_disc"
Totalsheets = Worksheets.Count
For i = 1 To Totalsheets
If Worksheets(i).Name <> "Main" Or InStr(1, Worksheets(i).Name, " Checks") Or Worksheets(i).Name
<>_ "Field Lists" Then
lastrow = Worksheets(i).Cells(Rows.Count, 4).End(xlUp).Row
For j = 2 To lastrow
If Worksheets(i).Cells(1, 3).Value = Keyword Then
Worksheets("Field Lists").Activate
lastrow = Worksheets("Field Lists").Cells(Rows.Count, 4).End(xlUp).Row
Worksheets("Field Lists").Cells(lastrow + 1, 5).Value = Worksheets(i).Name
Worksheets("Field Lists").Cells(lastrow + 2, 5).Value = Worksheets(i).Name
End If
Next
End If
Next
End Sub
The following code should work for what you described.
A couple feedback items:
Tabbing out loops and if statements significantly improves code readability
Never reuse variable names (i.e. lastrow), it makes it hard to read and can cause issues that are difficult to find later on
Follow all Next with the loop variable (i.e. Next i), this improves readability and helps you keep track of the ends of loops
.Activate and .Select are generally never required in vba, its better to be explicit in what you are referencing
Sub FinalAppendVar()
Dim searchSheet As Excel.Worksheet
Dim pasteSheet As Excel.Worksheet
Dim keyword As String
Dim lastSearchRow As Integer
Dim lastPasteRow As Integer
' set the worksheet to paste to
Set pasteSheet = ThisWorkbook.Worksheets("Field Lists")
' set keyword to look for
keyword = "adj_veh_smart_tech_disc" '<-- manual entry
'keyword = pasteSheet.Range("A1").Value '<-- use value in cell A1 on the defined pasteSheet
' loop through all sheets in the workbook
For i = 1 To ThisWorkbook.Worksheets.Count
' set the current worksheet we are looking at
Set searchSheet = ThisWorkbook.Worksheets(i)
' check if the current sheet is one we want to search in
If searchSheet.Name <> "Main" Or InStr(1, searchSheet.Name, " Checks") Or searchSheet.Name <> "Field Lists" Then
' current worksheet is one we want to search in
' find the last row of data in column D of the current sheet
lastSearchRow = searchSheet.Cells(1048576, 4).End(xlUp).Row
' loop through all rows of the current sheet, looking for the keyword
For j = 2 To lastSearchRow
If searchSheet.Cells(j, 3).Value = keyword Then
' found the keyword in row j of column C in the current sheet
' find the last row of column D in the paste sheet
'lastPasteRow = pasteSheet.Cells(1048576, 4).End(xlUp).Row
lastPasteRow = pasteSheet.Cells(1048576, 5).End(xlUp).Row '<-- update based on OPs comment
' paste the name of the current search sheet to the last empty cell in column E
pasteSheet.Cells(lastPasteRow + 1, 5).Value = searchSheet.Name
' not sure if the next line is needed, looks like it pastes again immediately below the previous
pasteSheet.Cells(lastPasteRow + 2, 5).Value = searchSheet.Name
' to save time consider exiting the search in the current sheet since the keyword was just found
' this will move to the next sheet immediately and not loop through the rest of the rows on the current
' search sheet. This may not align with the usecase so it is currently commented out.
'Exit For '<--uncomment this to move to the next sheet after finding the first instance of the keyword
Else
' the keyoword was not in row j of column C
' do nothing
End If
Next j
Else
' current sheet is one we don't want to search in
' do nothing
End If
Next i
End Sub
Please try this variant (Don't worry that the code is so long - the longer the programmer thought and the more wrote, the better the program works ... usually it is):
Option Explicit
Sub collectLinks()
Const LIST_SHEET_NAME As String = "Field Lists"
Dim wsTarget As Worksheet
Dim wsEach As Worksheet
Dim keywordCell As Range
Dim sKeyword As String
Dim linkCell As Range
Dim aFound As Range
Dim aCell As Range
On Error Resume Next
Set wsTarget = ActiveWorkbook.Worksheets(LIST_SHEET_NAME)
On Error GoTo 0
If wsTarget Is Nothing Then
MsgBox "'" & LIST_SHEET_NAME & "' not exists in active workbook", vbCritical, "Wrong book or sheet name"
Exit Sub
End If
Rem Clear all previous results (from column B to end of data)
wsTarget.UsedRange.Offset(0, 1).ClearContents
Rem Repeat for each cell of column A in UsedRange:
For Each keywordCell In Application.Intersect(wsTarget.UsedRange, wsTarget.Columns("A")) ' It can be changed to "D", "AZ" or any other column
sKeyword = keywordCell.Text
If Trim(sKeyword) <> vbNullString Then
Application.StatusBar = "Processed '" & sKeyword & "'"
Set linkCell = keywordCell
For Each wsEach In ActiveWorkbook.Worksheets
If wsEach.Name <> LIST_SHEET_NAME Then
Application.StatusBar = "Processed '" & sKeyword & "' Search in '" & wsEach.Name & "'"
Set aFound = FindAll(wsEach.UsedRange, sKeyword)
If Not aFound Is Nothing Then
For Each aCell In aFound
Set linkCell = linkCell.Offset(0, 1) ' Shift to rught, to the next column
linkCell.Formula2 = "=HYPERLINK(""#" & aCell.Address(False, False, xlA1, True) & """,""" & _
aCell.Worksheet.Name & " in cell " & aCell.Address(False, False, xlA1, False) & """)"
Next aCell
End If
End If
Next wsEach
End If
Next keywordCell
Application.StatusBar = False
Rem Column width
wsTarget.UsedRange.Columns.AutoFit
End Sub
Function FindAll(SearchRange As Range, FindWhat As Variant) As Range
Dim FoundCell As Range
Dim FirstFound As Range
Dim LastCell As Range
Dim ResultRange As Range
Dim Area As Range
Dim MaxRow As Long
Dim MaxCol As Long
For Each Area In SearchRange.Areas
With Area
If .Cells(.Cells.Count).Row > MaxRow Then
MaxRow = .Cells(.Cells.Count).Row
End If
If .Cells(.Cells.Count).Column > MaxCol Then
MaxCol = .Cells(.Cells.Count).Column
End If
End With
Next Area
Set LastCell = SearchRange.Worksheet.Cells(MaxRow, MaxCol)
Rem If your keyword can be a part of cell then change parameter xlWhole to xlPart:
Set FoundCell = SearchRange.Find(FindWhat, LastCell, xlValues, xlWhole, xlByRows)
If Not FoundCell Is Nothing Then
Set FirstFound = FoundCell
Do Until False ' Loop forever. We'll "Exit Do" when necessary.
If ResultRange Is Nothing Then
Set ResultRange = FoundCell
Else
Set ResultRange = Application.Union(ResultRange, FoundCell)
End If
Set FoundCell = SearchRange.FindNext(after:=FoundCell)
If (FoundCell Is Nothing) Then
Exit Do
End If
If (FoundCell.Address = FirstFound.Address) Then
Exit Do
End If
Loop
End If
Set FindAll = ResultRange
End Function
You can see how it works in this demo workbook - Create Links To Keywords.xlsm
EDIT By the way, the second part of this code, the FindAll() function, is a slightly shortened version of the Chip Pearson macro. Keep this link for yourself, there are many useful things to help you in future development.
My knowledge in VBA coding is zero. I wonder if someone can help with this question, please.
I have this initial code tried to write but it is wrong. I was not sure how to add these below conditions in the code.
Question: I want to auto number column A which starts at a specific Cell, A3 and it auto-numbers as long as there is text in Column B and Column C.
Here's the sample data picture. Thanks in advance!
Sub test()
Set r = Range("a3", Range("b" & Rows.Count).End(xlUp)).Offset(, -1)
With r
If .MergeCells <> True Then
r = r +1
Else
' Skip
End With
End Sub
Assuming your sheet is named Sheet1, you may use something like this:
Sub Test()
Dim lastRow As Long, i As Long, counter As Long
With Sheet1
lastRow = .Range("B" & .Rows.Count).End(xlUp).Row
For i = 3 To lastRow
If Not IsEmpty(.Cells(i, 2)) And Not IsEmpty(.Cells(i, 3)) Then
counter = counter + 1
.Cells(i, 1).Value = counter
End If
Next
End With
End Sub
Note: Using IsEmpty to check if any of the cells in columns B & C is empty already covers the case of cells being merged because in that case, at least one of the two cells has to be empty anyway.
Demo:
You have r as a range, you can't add a number to it and have it increment the range. (Though I did just test it and it doesn't throw an error which is strange)
Also Skip is not a thing in VBA, if you want to skip in a loop you need a conditional or a goto. Though you have no loop.
Sub test()
Dim i As Long
Dim lastrow As Long
Dim counter As Long
counter = 1
With ActiveSheet ' Change this to the real sheet name
lastrow = .Cells(.Rows.Count, 2).End(xlUp).Row ' Gets Last row
For i = 3 To lastrow ' Loop
If not isempty(.Cells(i, 2).Value) And not IsEmpty(.Cells(i, 3).Value) Then ' Looks for Text
If Not .Cells(i, 1).MergeCells Then ' Looks for merged cells
.Cells(i, 1).Value = counter ' Adds count
counter = counter + 1 ' Increments count
End If
End If
Next i
End With
See for comments and customize to fit your needs:
Public Sub AutoNumber()
' Declare objects
Dim evalRange As Range
Dim evalCell As Range
' Declare other variables
Dim sheetName As String
Dim initialCellAddress As String
Dim lastRow As Long
Dim columnNumber As Long
Dim counter As Long
' Customize to fit your needs
sheetName = "Sheet1"
initialCellAddress = "B2"
counter = 1
' Get column number and last row number to define the range address ahead
columnNumber = Range(initialCellAddress).Column
lastRow = ThisWorkbook.Worksheets(sheetName).Cells(Rows.Count, columnNumber).End(xlUp).Row
' Define the range to be evaluated
Set evalRange = ThisWorkbook.Worksheets(sheetName).Range(initialCellAddress & ":" & Left$(initialCellAddress, 1) & lastRow)
' Loop through each cell in range (in the original example we'll loop through column b)
For Each evalCell In evalRange
If evalCell.MergeCells <> True Then
' Assign the counter to the column at the left (offset = -1) of the evaluated cell
evalCell.Offset(rowoffset:=0, columnOffset:=-1).Value2 = counter
counter = counter + 1
End If
Next evalCell
End Sub
I have encountered a problem during my work.
There are over one hundred worksheets in my excel, and I would like to extract values from certain location (I25:K25, I50:K50, I95:K95) along with the worksheet name on the beside for every worksheet.
I would like to have these extracted values pasted on a new worksheet.
Does anyone know if there is any excel formula or excel macro I could use to achieve the goal?
I'm not proficient with formulas, but it would certainly be doable with VBA.
Look into For Each..Next loops, which I think you should use to go through all sheets.
Next, the .Name property will extract the sheet's name for you. You can save this to a variable and fill a cell with.
Getting values from one cell to another is as easy as
.Sheets(1).Range("A1:B1").Value = .Sheets(2).Range("A1:B1").Value
Note that SO is not a free code writing service, so I won't go as far as writing the entire procedure for you. If you have some code but encounter problems, come back to us.
Useful links:
looping through sheets
Copying cell values
Workbook and -sheet objects
This code loop all sheets except sheet called Results, code sheet name in column A and range values in columns B:D.
Option Explicit
Sub test()
Dim ws As Worksheet, wsResults As Worksheet
Dim Lastrow As Long
With ThisWorkbook
Set wsResults = .Worksheets("Results")
For Each ws In .Worksheets
If ws.Name <> "Results" Then
Lastrow = wsResults.Cells(wsResults.Rows.Count, "A").End(xlUp).Row
wsResults.Range("A" & Lastrow + 1 & ":A" & Lastrow + 3).Value = ws.Name
ws.Range("I25:K25").Copy wsResults.Range("B" & Lastrow + 1)
ws.Range("I50:K50").Copy wsResults.Range("B" & Lastrow + 2)
ws.Range("I95:K95").Copy wsResults.Range("B" & Lastrow + 3)
End If
Next ws
End With
End Sub
Ranges to New Master Worksheet
Workbook
Download
(Dropbox)
Adjust the values in the constants (Const) section to fit your
needs.
The code will only affect the workbook containing it.
The code will delete a possible existing worksheet named after
cTarget, but will only read from all other worksheets. Then it will
create a worksheet named after cTarget and write the read data to it.
To run the code, go to the Developer tab and click Macros and
click RangesToNewMasterWorksheet.
Sub RangesToNewMasterWorksheet()
' List of Source Row Range Addresses
Const cRowRanges As String = "I25:K25, I50:K50, I95:K95"
Const cTarget As String = "Result" ' Target Worksheet Name
Const cHead1 As String = "ID" ' 1st Column Header
Const cHead2 As String = "Name" ' 2nd Column Header
Const cHead As Long = 2 ' Number of First Header Columns
Const cRange As String = "Rng" ' Range (Area) String
Const cColumn As String = "C" ' Column String
Const cFirstCell As String = "A1" ' Target First Cell Range Address
Dim wb As Workbook ' Source/Target Workbook
Dim ws As Worksheet ' Current Source/Target Worksheet
Dim rng As Range ' Current Source/Target Range
Dim vntT As Variant ' Target Array
Dim vntA As Variant ' Areas Array
Dim vntR As Variant ' Range Array
Dim NoA As Long ' Number of Areas
Dim NocA As Long ' Number of Area Columns (in Target Array)
Dim i As Long ' Area Counter
Dim j As Long ' Area Column Counter
Dim k As Long ' Target Array Row Counter
Dim m As Long ' Target Array Column Counter
' Speed Up.
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
' Create a reference to ThisWorkbook i.e. the workbook containing this code.
Set wb = ThisWorkbook
' Task: Delete a possibly existing instance of Target Worksheet.
Application.DisplayAlerts = False
On Error Resume Next
wb.Worksheets(cTarget).Delete
On Error GoTo 0
Application.DisplayAlerts = True
' Handle unexpected error.
On Error GoTo UnExpected
' Task: Calculate size of Target Array.
' Create a reference to the 1st worksheet. (Note: Not sheet.)
For Each ws In wb.Worksheets
Exit For
Next
' Create a reference to the Source Row Range (in 1st worksheet.
Set rng = ws.Range(cRowRanges)
With rng
NoA = .Areas.Count
ReDim vntA(1 To NoA)
' Calculate Number of Area Columns (NocA).
For i = 1 To NoA
With .Areas(i)
' Write number of columns of current Area (i) to Areas Array.
vntA(i) = .Columns.Count
NocA = NocA + vntA(i)
End With
Next
End With
' Resize Target Array.
' Rows: Number of worksheets + 1 for headers.
' Columns: Number of First Header Columns + Number of Area Columns.
ReDim vntT(1 To wb.Worksheets.Count + 1, 1 To cHead + NocA)
' Task: Write 'Head' (headers) to Target Array.
vntT(1, 1) = cHead1
vntT(1, 2) = cHead2
k = cHead
For i = 1 To NoA
For j = 1 To vntA(i)
k = k + 1
vntT(1, k) = cRange & i & cColumn & j
Next
Next
' Task Write 'Body' (all except headers) to Target Array.
k = 1
For Each ws In wb.Worksheets
k = k + 1
vntT(k, 1) = k - 1
vntT(k, 2) = ws.Name
Set rng = ws.Range(cRowRanges)
m = cHead
For i = 1 To NoA
vntR = rng.Areas(i)
For j = 1 To vntA(i)
m = m + 1
vntT(k, m) = vntR(1, j)
Next
Next
Next
' Task: Copy Target Array to Target Worksheet.
' Add new worksheet to first tab (1).
Set ws = wb.Sheets.Add(Before:=wb.Sheets(1))
ws.Name = cTarget
' Calculate Target Range i.e. resize First Cell Range by size of
' Target Array.
Set rng = ws.Range(cFirstCell).Resize(UBound(vntT), UBound(vntT, 2))
rng = vntT
' Task: Apply Formatting.
' Apply formatting to Target Range.
With rng
.Columns.AutoFit
' Apply formatting to Head (first row).
With .Resize(1)
.Interior.ColorIndex = 49
With .Font
.ColorIndex = 2
.Bold = True
End With
.BorderAround xlContinuous, xlThin
.Borders(xlInsideVertical).LineStyle = xlContinuous
End With
' Apply formatting to Body (all except the first row).
With .Resize(rng.Rows.Count - 1).Offset(1)
.Interior.ColorIndex = xlColorIndexNone
With .Font
.ColorIndex = xlColorIndexAutomatic
.Bold = False
End With
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
End With
End With
MsgBox "The program finished successfully.", vbInformation, "Success"
ProcedureExit:
' Speed Down.
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
Exit Sub
UnExpected:
MsgBox "An unexpected error occurred. Error '" & Err.Number & "': " _
& Err.Description, vbCritical, "Error"
GoTo ProcedureExit
End Sub