VBA script to format cells within a column range only formats the first sheet in the workbook - excel

I have successfully scripted VBA code for summarizing and formatting a large set of data within a sheet. The script is successful when the macro is run on the next sheet I select. When tasked to apply the script across all sheets in the workbook, the modified script completes the summarizations for each sheet, but only formats the first. We tried to troubleshoot in my data class, but to no avail. This is an image of what it is supposed to look like.
My script for the whole workbook:
Sub tickerdata_all_ws()
'define variables
dim ws as Worksheet
Dim ticker As String
Dim stock_vol As Long
Dim yrclose As Double
Dim yrchange As Double
Dim yrvar As Double
Dim i As Long
Dim sumrow As Integer
Dim lastrow As Long
lastrow = ActiveSheet.UsedRange.Rows.Count
for each ws in Worksheet
'create the column headers
ws.Range("H1").Value = "Ticker"
ws.Range("J1").Value = "Yearly Change"
ws.Range("K1").Value = "Percent Change"
ws.Range("L1").Value = "Total Stock Volume"
'which row our summaries will be placed for above columns
sumrow = 2
'the loop checks each iteration until the last row
For i = 2 To lastrow
'we need to capture the price of the ticker if it is the first of its year
Dim firstprice As Boolean
If firstprice = False Then 'false is the default boolean value, so this statement is true
Dim yropen As Double
yropen = ws.Cells(i, 3).Value
firstprice = True 'we have captured the opening price of the year for the ticker
End If
'now we can check if we are in the same ticker value
If ws.Cells(i + 1, 1).Value <> ws.Cells(i, 1).Value Then
'this should happen when the cell values are finally different / capture all the values
ticker = ws.Cells(i, 1).Value
stock_vol = ws.Cells(i, 7).Value
yrclose = ws.Cells(i, 6).Value
yrchange = yrclose - yropen
If yropen <> 0 Then 'this prevents dividing by zero which will result in overflow error 6
yrvar = (yrclose - yropen) / yrclose
Else
yrvar = 0
yrchange = 0
End If
'insert values into the summary
ws.Cells(sumrow, 9).Value = ticker
ws.Cells(sumrow, 10).Value = yrchange
ws.Cells(sumrow, 11).Value = yrvar
ws.Cells(sumrow, 12).Value = stock_vol
sumrow = sumrow + 1 'sets the stage for the next set of data into row 3
stock_vol = 0 'resets vol for the next ticker
firstprice = False 'allows the next 'first' open price of the loop to be captured
End If
Next i 'finish i iteration of the loop
ws.Range("K:K").NumberFormat = "0.0%" 'aesthetic preference
'format columns colors
Dim colJ As Range
Dim Cell as Range
Set colJ = Range("J2", Range("J2").End(xlDown)) 'from J2 to the last cell entry
For Each Cell In colJ
If Cell.Value > 0 Then
Cell.Interior.ColorIndex = 50
Cell.Font.ColorIndex = 2
ElseIf Cell.Value < 0 Then
Cell.Interior.ColorIndex = 30
Cell.Font.ColorIndex = 2
Else
Cell.Interior.ColorIndex = xlNone 'this really serves no purpose
End If
Next
next ws
End Sub
I am sure there are other, much better ways to accomplish this, but as a novice, this is my code salad, and I'd appreciate any help as to why it is not formatting the other three sheets.
Excel for Mac user, though I've run it via Parallels as well.

Set colJ = Range("J2", Range("J2").End(xlDown)) 'from J2 to the last cell entry
here you get range for active sheet.
Change to:
Set colJ = ws.Range("J2", ws.Range("J2").End(xlDown))

Related

Why is my array returning empty? And how do I ensure it copies the data into my third selection

After countless efforts to keep the array "newvarray" within range, I am now running into a result of an empty array from a 278 line column. I believe this is also the root cause of my endgame function not executing (pasting unmatched values into the rolls sheet)?
Clarification: the actualy empty cells report on locals as "Empty", the columns with string report as " "" "
Dim oldsht As Worksheet
Dim newsht As Worksheet
Dim rollsht As Worksheet
Dim a As Integer
Dim b As Integer
Dim c As Integer
Set oldsht = ThisWorkbook.Sheets("Insert Yesterday's Report Here")
Set newsht = ThisWorkbook.Sheets("Insert Today's Report Here")
Set rollsht = ThisWorkbook.Sheets("Rolls")
Dim OldVArray(), NewVArray(), RollArray() As String
ReDim Preserve OldVArray(1 To oldsht.Range("a" & Rows.Count).End(xlUp).Row - 1, 5 To 5)
ReDim Preserve NewVArray(2 To newsht.Range("a" & Rows.Count).End(xlUp).Row, 5 To 5)
ReDim Preserve RollArray(1 To rollsht.Range("a" & Rows.Count).End(xlUp).Row - 1, 3 To 3)
For a = 2 To oldsht.Range("E" & Rows.Count).End(xlUp).Row
OldVArray(a, 5) = oldsht.Cells(a, 5)
Next a
For b = 2 To newsht.Range("E" & Rows.Count).End(xlUp).Row
NewVArray(b, 5) = newsht.Cells(b, 5)
Next b
For c = 2 To rollsht.Range("C" & Rows.Count).End(xlUp).Row
RollArray(c, 3) = rollsht.Cells(c, 3)
Next c
Dim Voyage As String
For a = 2 To UBound(OldVArray)
Voyage = OldVArray(a, 5)
For b = 2 To UBound(NewVArray)
voyage2 = NewVArray(b, 5)
If voyage2 <> Voyage Then
If voyage2 <> "" Then
For Each cell In NewVArray
voyage2 = rollsheet.Range("C:C")
Next
End If
End If
Next
Next
Here are snips of sample idea, highlighted are the rows that need to be found, and the voyage that changed is in orange. Third on Rolls would be the output of the macro.
Oldsheet:
Newsheet:
Rolls:
Untested, but this is how I'd do it. Just going from your screenshots. If your actual data looks different then you will need to make some adjustments.
Sub test()
Dim wb As Workbook, oldsht As Worksheet, newsht As Worksheet, rollsht As Worksheet
Dim c As Range, id, col, cDest As Range, copied As Boolean, m
Set wb = ThisWorkbook
Set oldsht = wb.Sheets("Insert Yesterday's Report Here")
Set newsht = wb.Sheets("Insert Today's Report Here")
Set rollsht = wb.Sheets("Rolls")
'next empty row on Rolls sheet
Set cDest = rollsht.Cells(Rows.Count, "A").End(xlUp).Offset(1)
'loop colA on new sheet
For Each c In newsht.Range("A2:A" & newsht.Cells(Rows.Count, "A").End(xlUp).row).Cells
id = c.Value 'identifier from Col A
If Len(id) > 0 Then
m = Application.Match(id, oldsht.Columns("A"), 0) 'check for exact match on old sheet
If Not IsError(m) Then
'got a match: check for updates in cols B to C
copied = False
For col = 2 To 3
If c.EntireRow.Cells(col).Value <> oldsht.Cells(m, col).Value Then
If Not copied Then 'already copied this row?
cDest.Resize(1, 3).Value = c.Resize(1, 3).Value 'copy changed row
Set cDest = cDest.Offset(1) ' next empy row
copied = True
End If
cDest.EntireRow.Cells(col).Interior.Color = vbRed 'flag updated value
End If
Next col
Else
cDest.Resize(1, 3).Value = c.Resize(1, 3).Value 'copy new row
Set cDest = cDest.Offset(1) ' next empy row
End If
End If
Next c
End Sub

VBA searching for data across workbooks

I am working as a Data Analyst for a software startup where I am required to write macros to analyse and sort data more efficiently. I am currently working on a macro that takes a value one workbook ("Job MMRF") and searches for it in another ("U100 Material Information"). My code is as follows:
Sub MMRFValidation()
Dim c As Range
Dim leadtime As Double
Dim price As Double
Application.ScreenUpdating = False
With Workbooks("Job MMRF.csv")
For Each c In Range("C:C")
If c.Value = "" Then
c.Offset(, -2).Font.Color = vbRed
c.Offset(, 9).Value = "Need to contact vendor"
c.Offset(, 10).Value = "Need to contact vendor"
Else
Dim a As Range
With Workbooks("U100 Material Information.xlsx")
For Each a In Range("A:A")
If a.Value = c.Value Then
price = a.Offset(, 15).Value
leadtime = a.Offset(, 13).Value
End If
Next a
End With
If price = 0.01 And leadtime = 21 Then
c.Offset(, -2).Font.ColorIndex = 7
c.Offset(, 9).Value = leadtime
c.Offset(, 10).Value = price
Else
c.Offset(, -2).Font.Color = vbGreen
c.Offset(, 9).Value = leadtime
c.Offset(, 10).Value = price
End If
End If
Next c
End With
Application.ScreenUpdating = True
End Sub
c is the value from the first workbook. I am trying to find c in the second workbook. If it is found, I want to copy the values from the 13th and 15th column in the U100 wb (associated with the row where c was found) and paste these values into the 9th and 10th row in JobMMRF (associated with the row where c initially was). The part of the code that changes font color works, but the price/lead time part does not. Pls help, thanks.
edit: I have updated the code. Now it pulls price and leadtime values, but for some reason they are always 0.
Sample data
I've refactored your code.
Read the comments and adjust it to fit your needs
EDIT: I have modified the way it's handled the cases where the csv cell value is different than an empty string.
Code:
Sub MMRFValidation()
Dim csvWorkbook As Workbook
Dim csvSheet As Worksheet
Dim csvRange As Range
Dim csvcell As Range
Dim csvLastRow As Long
Dim materialWorkbook As Workbook
Dim materialSheet As Worksheet
Dim materialRange As Range
Dim materialCell As Range
Dim materialLastRow As Long
Dim leadtime As Double
Dim price As Double
Application.ScreenUpdating = False
' Adjust workbook and worksheet names
Set csvWorkbook = Workbooks("Job MMRF.csv")
Set csvSheet = csvWorkbook.Worksheets("CSV SHEET NAME") ' <- ADJUST SHEET NAME
Set materialWorkbook = Workbooks("U100 Material Information.xlsx")
Set materialSheet = materialWorkbook.Worksheets("MATERIAL SHEET NAME") ' <- ADJUST SHEET NAME
' This looks for the last row in column C
csvLastRow = csvSheet.Cells(csvSheet.Rows.Count, "C").End(xlUp).Row
' This looks for the last row in column A
materialLastRow = materialSheet.Cells(materialSheet.Rows.Count, "A").End(xlUp).Row
' Set the range from C1 to last row
Set csvRange = csvSheet.Range("C1:C" & csvLastRow)
Set materialRange = materialSheet.Range("A1:A" & materialLastRow)
' Loop through each cell in target range
For Each csvcell In csvRange.Cells
' If no value
Select Case True
Case Trim(csvcell.Value) = vbNullString
csvcell.Offset(, -2).Font.Color = vbRed
csvcell.Offset(, 9).Value = "Need to contact vendor"
csvcell.Offset(, 10).Value = "Need to contact vendor"
' Reset if null?
price = 0
leadtime = 0
Case Else
' Get matching cell in material workbook
Set materialCell = GetMatchedCell(materialRange, csvcell.Value)
' If found
If Not materialCell Is Nothing Then
price = materialCell.Offset(, 15).Value
leadtime = materialCell.Offset(, 13).Value
Else
' Reset if not?
price = 0
leadtime = 0
End If
' Moved this to only the cases where the csvcell value is different than null
With csvcell
If price = 0.01 And leadtime = 21 Then
.Offset(, -2).Font.ColorIndex = 7
.Offset(, 9).Value = leadtime
.Offset(, 10).Value = price
Else
.Offset(, -2).Font.Color = vbGreen
.Offset(, 9).Value = leadtime
.Offset(, 10).Value = price
End If
End With
End Select
Next csvcell
Application.ScreenUpdating = True
End Sub
Private Function GetMatchedCell(ByVal lookupRange As Range, ByVal lookupValue As Variant) As Range
Dim lookupCell As Range
For Each lookupCell In lookupRange.Cells
If lookupCell.Value = lookupValue Then
Set GetMatchedCell = lookupCell
Exit For
End If
Next lookupCell
End Function
Let me know if it works

Data from multiple worksheets starts to imput in the wrong cell of the mastersheet

first time asker here.
I found a nice VBA code to copy the same specific cells from multiple worksheets into a mastersheets and actually does its job (i don't remember where I founf it originally). The only small issue is that it starts to input the data from cell A2, while I would like it to start from cell A4.
Here is the code:
Sub ListFB()
Sheets("Master").Range("A4").Value = "Sheet Name"
For I = 1 To ThisWorkbook.Worksheets.Count
If Sheets(I).Name <> "RiassuntoTEST" Then
Sheets("Master").Cells(I, 1).Value = Sheets(I).Range("B2").Value
Sheets("Master").Cells(I, 2).Value = Sheets(I).Range("C2").Value
Sheets("Master").Cells(I, 3).Value = Sheets(I).Range("C10").Value
Sheets("Master").Cells(I, 4).Value = Sheets(I).Range("C11").Value
Sheets("Master").Cells(I, 5).Value = Sheets(I).Range("C15").Value
Sheets("Master").Cells(I, 6).Value = Sheets(I).Range("C16").Value
Sheets("Master").Cells(I, 7).Value = Sheets(I).Range("C20").Value
Sheets("Master").Cells(I, 8).Value = Sheets(I).Range("C21").Value
Sheets("Master").Cells(I, 9).Value = Sheets(I).Range("C25").Value
Sheets("Master").Cells(I, 10).Value = Sheets(I).Range("C26").Value
Sheets("Master").Cells(I, 11).Value = Sheets(I).Range("C29").Value
Sheets("Master").Cells(I, 12).Value = Sheets(I).Range("C30").Value
Sheets("Master").Cells(I, 13).Value = Sheets(I).Range("C33").Value
Sheets("Master").Cells(I, 14).Value = Sheets(I).Range("C34").Value
End If
Next I
End Sub
What I think it does is take value B2 from Sheet I and copy it to A2 of the mastersheet, then take C2 and copy it to B2, until it has all the required data from that sheet into the same rows, then goes to the next sheet and puts the data in the next rows. As I said above, I would like that this whole process starts from A4 instead of A2.
I am fairly new to this kind of stuff so any input and help is appreciated.
Also, does the row
Sheets("Master").Range("A4").Value = "Sheet Name"
Do anything for my purpose at all?
Thank you!
First issue:
Sheets("RiassuntoTEST").Cells(I, 1).Value
Cells holds what is known as an R1C1 reference. Meaning Row number, Column number. Since this line I = 1 To ThisWorkbook.Worksheets.Count counts from 1 to the number of worksheets you have, this will start pasting in row 1, column 1, also known as cell A1. If you want to up this to cell A4 instead, you will need to increase this by 3 like so:
Sheets("RiassuntoTEST").Cells(I + 3, 1).Value
You will need to do this on every line.
Second issue:
Also, does the row
Sheets("RiassuntoTEST").Range("A4").Value = "Nome Foglio"
Do anything for my purpose at all?
No, it does not, as stated before, your code will (now) start pasting at cell A4, so as soon as the second block starts running, this is overwritten.
I rewrote your code in such a way as to enable you to make all the amendments you might want - perhaps with a little help from the comments I inserted between the lines of code.
Option Explicit
Sub UpdateMaster()
' Variatus #STO 23 Jan 2020
Dim Wb As Workbook
Dim MasterWs As Worksheet
Dim Ws As Worksheet
Dim SourceCell() As String
Dim Rt As Long ' target row
Dim Ct As Long ' target column
Dim i As Integer
Set Wb = ThisWorkbook ' you might specify another workbook
' specify the Master worksheet here
Set MasterWs = Wb.Worksheets("TEST")
' list all the source cells here
SourceCell = Split("B2,C2,C10,C11,C15,C16,C20,C21,C25,C26,C29,C30,C33,C34", ",")
Rt = 4 ' set first row to write to here
With MasterWs
' keep contents in rows 1 to 3 (incl title)
.Range(.Cells(Rt, 1), .Cells(.Rows.Count, "A").End(xlUp) _
.Offset(0, UBound(SourceCell) + 1)) _
.ClearContents
End With
Application.ScreenUpdating = False ' speeds up execution
For i = 1 To Wb.Worksheets.Count
Set Ws = Wb.Worksheets(i)
If Not Ws Is MasterWs Then
For Ct = 0 To UBound(SourceCell)
MasterWs.Cells(Rt + i - 1, Ct + 1) = Ws.Range(Trim(SourceCell(Ct))).Value
Next Ct
End If
Next i
Application.ScreenUpdating = True
End Sub

Sum all column values after each import

My current code reads manhours(integer values) from different workbooks and exports them to a column in a master output sheet. After each import I want to sum the total amount of hours that is exported to the main sheet, however,
I'm unsure as to how to do so without summing the entire column. Additionally, after summing up the total manhours from each sheet, I want to compare this value with that from the sheet to confirm if I copied all the rows correctly.
My outputsheet looks like this after each import:
data----------data----------hours(sheet1)
data----------data----------hours(sheet1)
data----------data----------hours(sheet1)
data----------data----------hours(sheet2)
data----------data----------hours(sheet2)
My current code looks like this:
Option Explicit
Sub manhours()
Dim Files As Variant
Dim i As Long
Dim j As Long
Dim sh As worksheet
Dim outputsheet As Worksheet
Dim erow As long
Dim manhours As Long
Workbooks.Open Files(i)
Set sh = Sheets("manhours")
For j = 2 to 30
erow = outputsheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row 'empty row
If IsEmpty(Cells(j, 3) = False Then
outputsheet.Cells(erow, 1).Resize(1, 2).Value = sh.Cells(j, 1).Resize(1, 2).Value 'copies the first 2 columns containing other data values
outputsheet.Cells(erow, 3) = sh.Cells(j, 3) 'column 3 from sh contains manhours
End If
Next j
manhours = Application.WorksheetFunction.Sum(outputsheet.Columns(3)) 'unsure how to sum only the values from sheet i and not the entire column
MsgBox (manhours) ' msgbox than gives the total man hours
manhours = sh.Range("C31") 'total manhours from sheet is in sh.Range("C31")
'MsgBox (True/False) 'unsure how to do this
Next i
End Sub
I don't see the need to use WorksheetFunction.Sum here.
One option: keep a running sum, like this:
manhours = 0 ' reset manhours to 0 for each new file
For j = 2 to 30
If Not IsEmpty(sh.Cells(j, 3).Value) Then
...
outputsheet.Cells(erow, 3).Value = sh.Cells(j, 3).Value
manhours = manhours + sh.Cells(j, 3).Value ' could add an IsNumeric check here to avoid a Type Mismatch
End If
Next j
MsgBox manhours ' no parentheses
MsgBox manhours = sh.Range("C31").Value

Updating Prices from a master list through the workbook VBA

I have a master price worksheet (Test Price) with product name (col A) and price (col B). I want to create a macro that when you click a button it will update the prices through the entire workbook. The previous person in my position already created a MOD that will update prices throughout the WB if it is changed in one WS. I am trying to link the master list to that code. So loop through the list and update one sheet which will use the existing mod to update all other sheets. Can anyone please help with this?
This is the code that updates the sheets, I need to link the master price list to this:
Sub ChangePrice(row As String, price As String)
Dim cropVal As String: cropVal = Cells(row, 2).Value ' inefficient
Dim LastRow As Long
For Each ws In ActiveWorkbook.Worksheets
'simple check for division in A3 (stronger check may be needed)
If ws.Cells(3, 1).Value = "Division:" Then
LastRow = ws.Range("A" & Rows.count).End(xlUp).row
' starts in row 12, though data starts in 13
For i = 12 To LastRow
'check column 2 if crop is the same
If ws.Cells(i, 2).Value = cropVal Then
'if so, change its price in column 10
ws.Cells(i, 10).Value = price
'this handles situations where the symbol is attached
ElseIf ws.Cells(i, 2).Value = cropVal & "®" Then
ws.Cells(i, 10).Value = price
End If
Next i
End If
Next ws
End Sub
You could create a dictionary of the values and then pass the dictionary to the module. You would need to add a For Each loop to your master sheet to find the row with the product for each specific worksheet.
Sub CropValFind()
Dim ProdCol As Range, Cell As Range, PriceCol As Range
Set ProdCol = 'Your product column range here
Set PriceCol = 'Your Price Column range here
For Each Cell in ProdCol
Call ChangePrice(Cell.Value, CreateDictFromColumns("MasterSheetName", ProdCol.Column, PriceCol.Column))
Next
End Sub
Assuming your product and price columns are adjacent to each other and the values are strings:
Pulled from https://stackoverflow.com/a/33523909/10462532
Function CreateDictFromColumns(sheet As String, keyCol As String, valCol As String) As Dictionary
Set CreateDictFromColumns = New Dictionary
Dim rng As Range: Set rng = Sheets(sheet).Range(keyCol & ":" & valCol)
Dim i As Long
Dim lastCol As Long '// for non-adjacent ("A:ZZ")
lastCol = rng.Columns.Count
For i = 1 To rng.Rows.Count
If (rng(i, 1).Value = "") Then Exit Function
CreateDictFromColumns.Add rng(i, 1).Value, rng(i, lastCol).Value
Next
End Function
Then your ChangePrice Sub would look something like this.
Sub ChangePrice(row As String, price As Dictionary)
Dim cropVal As String: cropVal = row
Dim LastRow As Long
For Each ws In ActiveWorkbook.Worksheets
'simple check for division in A3 (stronger check may be needed)
If ws.Cells(3, 1).Value = "Division:" Then
LastRow = ws.Range("A" & Rows.count).End(xlUp).row
' starts in row 12, though data starts in 13
For i = 12 To LastRow
'check column 2 if crop is the same
If ws.Cells(i, 2).Value = cropVal Then
'if so, change its price in column 10
ws.Cells(i, 10).Value = price(row)
'this handles situations where the symbol is attached
ElseIf ws.Cells(i, 2).Value = cropVal & "®" Then
ws.Cells(i, 10).Value = price(row)
End If
Next i
End If
Next ws
End Sub
A great resource to learn the in's and outs of dictionaries can be found here.

Resources