Copy values from one sheet to another when column contents match - excel

I am looking for a similar formula, as here:
How to copy data from sheet1 to sheet2 with a condition in Excel
I am using:
=IF(EXACT(Sheet1!B4,Sheet2!A7),Sheet1!A4)
only I want to add the condition that if column B of sheet1 doesn't have the value that I am looking for it will look at the next row in column B. If this matches then the value of that row in column A would be the value copied.
Thanks

It seems clear that no one is going to offer you a formula solution. Certainly I would not know how to solve your problem with formulae.
You have not defined the format of either your source or your destination sheet. However, I had some code which I was able to hack around to match possible formats.
On the left of the image below is my source sheet. Note that column C contains a date which I have formatted as "ddd dd" because I find that a convenient format for this type of list. On the right is a print image of the output. The column widths, borders and cell merging are as set by the macro.
The sequence of station names is set by an array within the macro. I have three stations but this is arbitrary. The start date, start time, end time and end date in the output table are set by the earliest and latest values in the source table.
The original validation in the macro does not match your requirement so I have deleted it. You will need to add your own.
The macro does not notice that Angela has two stations at 12:00 on Tuesday. It does notice that source rows 13 and 18 overlap previous entries and reports these errors.
The code below includes comments explaining what it is doing but not why or how. I hope this gives you some ideas. Come back with questions if necessary.
Option Explicit
Type typStationBooking
NamePerson As String
NameStation As String
BookDate As Date
BookTimeStart As Long ' Time in minutes 540 = 9:00
BookTimeEnd As Long ' Time in minutes 900 = 15:00
End Type
Sub ListByNameToListByStation()
Dim ColDataCrnt As Long
Dim DateCrnt As Date
Dim DateLatest As Date
Dim DateEarliest As Date
Dim Found As Boolean
Dim InxBookCrnt As Long
Dim InxBookMax As Long
Dim InxStatCrnt As Long
Dim NumRowsPerDay As Long
Dim NumStations As Long
Dim NumTimeSlots As Long
Dim Occupied As Boolean
Dim RowDataCrnt As Long
Dim RowDataDayFirst As Long
Dim RowDataLast As Long
Dim RowDataTimeSlot As Long
Dim StationBooking() As typStationBooking
Dim StationName() As Variant
Dim SheetDest As String
Dim SheetSrc As String
Dim TimeCrnt As Long
Dim TimeEarliest As Long
Dim TimeLatest As Long
Dim TimeInterval As Long
' Names of stations in desired column sequence. Names must match
' those used in worksheet Source. LBound = 0
StationName = Array("Station2", "Station3", "Station1")
SheetDest = "Dest" ' ) Change to your
SheetSrc = "Source" ' ) sheet names
DateEarliest = -1
DateLatest = -1
TimeInterval = 30 ' ) Values in minutes. Change as necessary
TimeEarliest = -1
TimeLatest = -1
With Sheets(SheetSrc)
' First Last used row
RowDataLast = .Cells(Rows.Count, "A").End(xlUp).Row
' Reserve space for rows 2 to RowLast
ReDim StationBooking(1 To RowDataLast - 1)
InxBookMax = 0 ' No current entries
' Load data from Sheet1 table into array
For RowDataCrnt = 2 To RowDataLast
' ### The source data should be checked:
' * Person name non-blank
' * Station name matches value in StationName()
' * Day is date in range DateFirst to DateLast
' * Start and End times are times in range TimeFirst to
' TimeLast+TimeInteval with Start time before End time
' and both are of the form TimeStart + N*TimeInterval
' where is a positive integer
InxBookMax = InxBookMax + 1
StationBooking(InxBookMax).NamePerson = .Cells(RowDataCrnt, 1).Value
StationBooking(InxBookMax).NameStation = .Cells(RowDataCrnt, 2).Value
StationBooking(InxBookMax).BookDate = .Cells(RowDataCrnt, 3).Value
StationBooking(InxBookMax).BookTimeStart = _
Hour(.Cells(RowDataCrnt, 4).Value) * 60 + _
Minute(.Cells(RowDataCrnt, 4).Value)
StationBooking(InxBookMax).BookTimeEnd = _
Hour(.Cells(RowDataCrnt, 5).Value) * 60 + _
Minute(.Cells(RowDataCrnt, 5).Value)
If DateEarliest = -1 Then
DateEarliest = StationBooking(InxBookMax).BookDate
DateLatest = StationBooking(InxBookMax).BookDate
Else
If DateEarliest > StationBooking(InxBookMax).BookDate Then
DateEarliest = StationBooking(InxBookMax).BookDate
End If
If DateLatest < StationBooking(InxBookMax).BookDate Then
DateLatest = StationBooking(InxBookMax).BookDate
End If
End If
If TimeEarliest = -1 Then
TimeEarliest = StationBooking(InxBookMax).BookTimeStart
TimeLatest = StationBooking(InxBookMax).BookTimeEnd
Else
If TimeEarliest > StationBooking(InxBookMax).BookTimeStart Then
TimeEarliest = StationBooking(InxBookMax).BookTimeStart
End If
If TimeLatest < StationBooking(InxBookMax).BookTimeEnd Then
TimeLatest = StationBooking(InxBookMax).BookTimeEnd
End If
End If
Next
End With
With Sheets(SheetDest)
' Lay out destination sheet
' Format per day
' Row 1 : Date
' Row 2 : Station names
' Row 3+: One row per time interval from TimeEarliest to
' TimeLatest + TimeInteval
' Row N : Blank row
' Col 1 : Time
' Col 2+: Station name
' Delete current contents
.Cells.EntireRow.Delete
NumRowsPerDay = (TimeLatest - TimeEarliest) / TimeInterval + 3
NumStations = UBound(StationName) + 1
' Set column widths
.Columns(1).ColumnWidth = 6
For ColDataCrnt = 2 To NumStations + 1
.Columns(ColDataCrnt).ColumnWidth = 14
Next
RowDataCrnt = 1
DateCrnt = DateEarliest
Do While DateCrnt <= DateLatest
RowDataDayFirst = RowDataCrnt
.Range(.Cells(RowDataCrnt, 1), .Cells(RowDataCrnt, 1 + NumStations)).Merge
With .Cells(RowDataCrnt, 1)
.HorizontalAlignment = xlCenter
.NumberFormat = "dddd d mmmm"
.Value = DateCrnt
End With
RowDataCrnt = RowDataCrnt + 1
InxStatCrnt = 0
For ColDataCrnt = 2 To NumStations + 1
.Cells(RowDataCrnt, ColDataCrnt).Value = StationName(InxStatCrnt)
InxStatCrnt = InxStatCrnt + 1
Next
RowDataCrnt = RowDataCrnt + 1
TimeCrnt = TimeEarliest
Do While TimeCrnt < TimeLatest
With .Cells(RowDataCrnt, 1)
.NumberFormat = "hh:mm"
.Value = DateCrnt + TimeSerial(TimeCrnt \ 60, TimeCrnt Mod 60, 0)
End With
RowDataCrnt = RowDataCrnt + 1
TimeCrnt = TimeCrnt + TimeInterval
Loop
With .Range(.Cells(RowDataDayFirst, 1), _
.Cells(RowDataCrnt - 1, NumStations + 1))
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(192, 192, 192)
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(192, 192, 192)
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(192, 192, 192)
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(192, 192, 192)
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(192, 192, 192)
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(192, 192, 192)
End With
End With
RowDataCrnt = RowDataCrnt + 1
DateCrnt = DateSerial(Year(DateCrnt), Month(DateCrnt), Day(DateCrnt) + 1)
Loop
' Now place each entry in StationBooking in the appropriate cell(s)
For InxBookCrnt = 1 To InxBookMax
'Debug.Assert InxBookCrnt <> 17
DateCrnt = StationBooking(InxBookCrnt).BookDate
RowDataDayFirst = (DateCrnt - DateEarliest) * NumRowsPerDay + 1
TimeCrnt = StationBooking(InxBookCrnt).BookTimeStart
RowDataTimeSlot = RowDataDayFirst + 2 + _
(TimeCrnt - TimeEarliest) / TimeInterval
NumTimeSlots = (StationBooking(InxBookCrnt).BookTimeEnd - TimeCrnt) _
/ TimeInterval
Found = False
For InxStatCrnt = 0 To UBound(StationName)
If StationBooking(InxBookCrnt).NameStation = _
StationName(InxStatCrnt) Then
Found = True
Exit For
End If
Next
If Not Found Then
MsgBox ("Row " & InxBookCrnt + 1 & " of worksheet " & SheetSrc & _
"contains an unknown station name")
Else
ColDataCrnt = InxStatCrnt + 2
' Check space for this entry is not already occupied
Occupied = False
For RowDataCrnt = RowDataTimeSlot To RowDataTimeSlot + NumTimeSlots - 1
If .Cells(RowDataCrnt, ColDataCrnt) <> "" Then
Occupied = True
Exit For
End If
Next
If Not Occupied Then
If Range(.Cells(RowDataTimeSlot, ColDataCrnt), _
.Cells(RowDataTimeSlot + NumTimeSlots - 1, _
ColDataCrnt)).MergeCells Then
Occupied = True
End If
End If
If Occupied Then
MsgBox ("Row " & InxBookCrnt + 1 & " of worksheet " & SheetSrc & _
" overlaps a previous entry")
Else
' Entire slot is free
.Cells(RowDataTimeSlot, ColDataCrnt).Value = _
StationBooking(InxBookCrnt).NamePerson
If NumTimeSlots > 1 Then
With .Range(.Cells(RowDataTimeSlot, ColDataCrnt), _
.Cells(RowDataTimeSlot + NumTimeSlots - 1, ColDataCrnt))
.Merge
.WrapText = True
.VerticalAlignment = xlCenter
End With
End If
End If
End If
Next
End With
End Sub

The below sample could help you to copy values(row wise) from one sheet to another sheet based on matching column in From Sheet.
Sub TodaysActions()
Dim listSheetRange As Range
'Sheet to copy data From
Dim listSheet As Worksheet
'Sheet to copy data To
Dim actionSheet As Worksheet
Set listSheetRange = Worksheets("List").UsedRange
Set listSheet = Worksheets("List")
Set actionSheet = Worksheets("Action")
'Clear the To Sheet
actionSheet.UsedRange.Clear
'Row 1 of From Sheet contains the data to match
'Copy Header Row i.e Row 2 of From Sheet
listSheet.Rows(2).Copy Destination:=actionSheet.Rows(1)
currentActionRow = 2
For i = 3 To listSheetRange.Rows.Count
'Comparision Condition
If InStr(listSheetRange.Cells(i, 1), listSheetRange.Cells(1, 3)) Then
listSheet.Rows(i).Copy Destination:=actionSheet.Rows(currentActionRow)
currentActionRow = currentActionRow + 1
End If
Next i
'hide any unwanted columns
actionSheet.Columns(1).Hidden = 1
actionSheet.Activate
End Sub

Related

How to show results on desired sheet?

The below code is not showing the results on the "All Stock Analysis" sheet.
I tried doing a test after the activation of each worksheet (Range("I1).Interior.Color = vbGreen) and cell I1 turns green on each of the desired worksheets. What other tests can I try? No error msg pops up.
Sub AllStocksAnalysisRefactored()
Dim startTime As Single
Dim endTime As Single
yearValue = InputBox("What year would you like to run the analysis on?")
startTime = Timer
'Format the output sheet on All Stocks Analysis worksheet
Worksheets("All Stock Analysis").Activate
Range("A1").Value = "All Stocks (" + yearValue + ")"
'Create a header row
Cells(3, 1).Value = "Ticker"
Cells(3, 2).Value = "Total Daily Volume"
Cells(3, 3).Value = "Return"
'Initialize array of all tickers
Dim tickers(12) As String
tickers(0) = "AY"
tickers(1) = "CSIQ"
tickers(2) = "DQ"
tickers(3) = "ENPH"
tickers(4) = "FSLR"
tickers(5) = "HASI"
tickers(6) = "JKS"
tickers(7) = "RUN"
tickers(8) = "SEDG"
tickers(9) = "SPWR"
tickers(10) = "TERP"
tickers(11) = "VSLR"
'Activate data worksheet
Worksheets(yearValue).Activate
'Get the number of rows to loop over
RowCount = Cells(Rows.Count, "A").End(xlUp).Row
'1a) Create a ticker Index
Dim tickerIndex As Single
tickerIndex = 0
'1b) Create three output arrays
Dim tickerVolumes(12) As LongLong
Dim tickerstartingPrices(12) As Single
Dim tickerendingPrices(12) As Single
''2a) Create a for loop to initialize the tickerVolumes to zero.
For i = 0 To 11
tickerVolumes(i) = 0
''2b) Loop over all the rows in the spreadsheet.
For j = 2 To RowCount
'3a) Increase volume for current ticker
tickerVolumes(tickerIndex) = tickerVolumes(tickerIndex) + Cells(j, 8).Value
'3b) Check if the current row is the first row with the selected tickerIndex.
'If Then
If Cells(j - 1, 1).Value <> tickers(tickerIndex) And _
Cells(j, 1).Value = tickers(tickerIndex) Then
tickerstartingPrices(tickerIndex) = Cells(j, 6).Value
'End If
End If
'3c) check if the current row is the last row with the selected ticker
'If the next row’s ticker doesn’t match, increase the tickerIndex.
'If Then
If Cells(j + 1, 1).Value <> tickers(tickerIndex) And _
Cells(j, 1).Value = tickers(tickerIndex) Then
tickerendingPrices(tickerIndex) = Cells(j, 6).Value
'3d Increase the tickerIndex.
tickerIndex = tickerIndex + 1
'End If
End If
Next j
Next i
'4) Loop through your arrays to output the Ticker, Total Daily Volume, and Return.
For i = 0 To 11
Worksheets("All Stock Analysis").Activate
Next i
'Formatting
Worksheets("All Stock Analysis").Activate
Range("A3:C3").Font.FontStyle = "Bold"
Range("A3:C3").Borders(xlEdgeBottom).LineStyle = xlContinuous
Range("B4:B15").NumberFormat = "#,##0"
Range("C4:C15").NumberFormat = "0.0%"
Columns("B").AutoFit
dataRowStart = 4
dataRowEnd = 15
For i = dataRowStart To dataRowEnd
If Cells(i, 3) > 0 Then
Cells(i, 3).Interior.Color = vbGreen
Else
Cells(i, 3).Interior.Color = vbRed
End If
Next i
endTime = Timer
MsgBox "This code ran in " & (endTime - startTime) & _
" seconds for the year " & (yearValue)
End Sub
Here is how "All Stock Analysis" sheet will look after running the code:
You only need to scan the data sheet once if you use a dictionary object to convert the ticker ID to an array index number.
Option Explicit
Sub AllStocksAnalysisRefactored()
Const SHT_NAME = "All Stock Analysis"
Dim wb As Workbook, ws As Worksheet, wsYr As Worksheet
Dim cell As Range, yr As String, iRow As Long, iLastRow As Long
Dim t As Single: t = Timer
' choose data worksheet
yr = InputBox("What year would you like to run the analysis on ? ", "Enter Year", Year(Date))
Set wb = ThisWorkbook
On Error Resume Next
Set wsYr = wb.Sheets(yr)
On Error GoTo 0
' check if exists
If wsYr Is Nothing Then
MsgBox "Sheet '" & yr & "' does not exists.", vbCritical, "Error"
Exit Sub
End If
'Initialize array of all tickers
Dim tickerID, tickerData(), i As Integer, n As Integer
Dim dict As Object, sId As String
tickerID = Array("AY", "CSIQ", "DQ", "ENPH", "FSLR", "HASI", _
"JKS", "RUN", "SEDG", "SPWR", "TERP", "VSLR")
n = UBound(tickerID) + 1
ReDim tickerData(1 To n, 1 To 5)
' create dict id to index
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To n
sId = UCase(Trim(tickerID(i - 1)))
tickerData(i, 1) = sId ' id
tickerData(i, 2) = 0 ' volume
tickerData(i, 3) = 0 ' start price
tickerData(i, 4) = 0 ' finish price
tickerData(i, 5) = 0 ' count
dict.Add sId, i
Next
'Get the number of rows to loop over
iLastRow = wsYr.Cells(Rows.Count, "A").End(xlUp).Row
' Loop over all the rows in the spreadsheet.
' A=ticker, F=Price , H=Volume
For iRow = 2 To iLastRow
sId = UCase(Trim(wsYr.Cells(iRow, "A")))
If dict.exists(sId) Then
i = dict(sId)
' volume
tickerData(i, 2) = tickerData(i, 2) + wsYr.Cells(iRow, "H") ' volume
' start price when count is 0
If tickerData(i, 5) = 0 Then
tickerData(i, 3) = wsYr.Cells(iRow, "F")
End If
' end price
tickerData(i, 4) = wsYr.Cells(iRow, "F")
' count
tickerData(i, 5) = tickerData(i, 5) + 1
End If
Next
'Format the output sheet on All Stocks Analysis worksheet
Set ws = wb.Sheets(SHT_NAME)
ws.Cells.Clear
With ws
.Range("A1").Value2 = "All Stocks (" & yr & ")"
With .Range("A3:E3")
.Value2 = Array("Ticker", "Total Daily Volume", "Start Price", "End Price", "Return")
.Font.FontStyle = "Bold"
.Borders(xlEdgeBottom).LineStyle = xlContinuous
End With
.Range("A4").Resize(n, 4).Value2 = tickerData
.Range("B4:D4").Resize(n).NumberFormat = "#,##0"
.Range("E4").Resize(n).NumberFormat = "0.0%"
.Columns("B").AutoFit
End With
' coloring
For Each cell In ws.Range("E4").Resize(n)
cell.FormulaR1C1 = "=(RC[-1]-RC[-2])/RC[-2]" ' end-start/start
If cell > 0 Then
cell.Interior.Color = vbGreen
Else
cell.Interior.Color = vbRed
End If
Next
ws.Activate
ws.Range("A1").Select
MsgBox "This code ran for (" & yr & ")", vbInformation, Int(Timer - t) & " seconds"
End Sub

Merge cells with same year in a row

I need to merge the cells one above the months.
Cells Should be merged from 01 to 12 showing year in cell.
Look for the picture for more clarification.
I have below code, but which show months after run in cell row1.
My idea is to convert above cells to years through vba and apply merge same year at the end.
which is shown in desired output.
Note.
ROW 4 and 5 are just my thinking, which will help year to merge.
Dim a(), i As Long, j As Long, m As Long, x As Range
With Range("b1:qaz1")
.MergeCells = False
.ClearContents
a() = .Offset(1).Value
m = Month(a(1, 1))
j = UBound(a, 2)
Set x = .Cells(1)
For i = 2 To j
If m <> Month(a(1, i)) Or i = j Then
With Range(x, .Cells(i - IIf(i = j, 0, 1)))
.MergeCells = True
.HorizontalAlignment = xlCenter
End With
x.Value = Format(DateSerial(2000, m, 1), "MMMM")
m = Month(a(1, i))
Set x = .Cells(i)
End If
Next
End With
End Sub
After running new program output look like
Since you have true dates in your caption row the month and year can be extracted from there. However, the code below converts dates that might have been created using formulas to hard dates before processing them.
Sub MergeCaptionsByYear()
' 031
Const CapsRow As Long = 1 ' change to suit
Const StartClm As Long = 2 ' change to suit
Dim Rng As Range ' working range
Dim Tmp As Variant ' current cell's value
Dim Cl As Long ' last used column
Dim Cstart As Long ' first column in Rng
Dim C As Long ' working column
Dim Yr As Integer ' year
Cl = Cells(CapsRow, Columns.Count).End(xlToLeft).Column
Range(Cells(CapsRow, StartClm), Cells(CapsRow, Cl)).Copy
Cells(CapsRow, StartClm).PasteSpecial xlValues
Application.CutCopyMode = False
C = StartClm - 1
Application.DisplayAlerts = False
Do
Tmp = Cells(CapsRow, C + 1).Value
If Not IsDate(Tmp) And (C <> Cl) Then
MsgBox "Cell " & Cells(CapsRow, C + 1).Address(0, 0) & _
" doesn't contain a date." & vbCr & _
"This macro will be terminated.", _
vbInformation, "Invalid cell content"
Exit Do
End If
If (Yr <> Year(CDate(Tmp))) Or (C = Cl) Then
If Yr Then
Set Rng = Range(Cells(CapsRow, Cstart), _
Cells(CapsRow, C))
With Rng
.Merge
.HorizontalAlignment = xlCenter
.NumberFormat = "yyyy"
End With
SetBorder Rng, xlEdgeLeft
SetBorder Rng, xlEdgeRight
End If
If C > (Cl - 1) Then Exit Do
Cstart = C + 1
Yr = Year(Tmp)
End If
C = C + 1
Loop
Application.DisplayAlerts = True
End Sub
Private Sub SetBorder(Rng As Range, _
Bord As XlBordersIndex)
' 031
With Rng.Borders(Bord)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlMedium ' xlThin
End With
End Sub
Assuming the months range is "B5:AH5"
Sub test()
Dim monthsRng As Range
Set monthsRng = Range("B5:AH5")
monthsRng.Cells(1, 1).Offset(-1, 0).Select
For j = 1 To Int((monthsRng.Cells.Count / 12) + 2)
If ActiveCell.Offset(1, 0) <> 0 Then
For i = 1 To 12
ActiveCell.Value = Year(ActiveCell.Offset(1, 0))
If Year(ActiveCell.Offset(1, i)) = ActiveCell Then
Selection.Resize(1, i + 1).Select
Else
Exit For
End If
Next
With Selection
.HorizontalAlignment = xlCenter
.MergeCells = True
End With
Selection.Offset(0, 1).Select
Else
Exit For
End If
Next
End Sub
Replacing the inner for loop with below code will work irrespective of whether the dates in the Range("B5:AH5") in above procedure are formatted as dates or not.
For i = 1 To 12
ActiveCell.Value = Right(Format(ActiveCell.Offset(1, 0), "DD.MM.YYYY"), 4)
If Right(Format(ActiveCell.Offset(1, i), "DD.MM.YYYY"), 4) = Format(ActiveCell, Text) Then
Selection.Resize(1, i + 1).Select
Else
Exit For
End If
Next
However, in any case you need to format the output in excel as number (without 1000 separator and decimal places) and not date.

How to create a macro which will copy data from row to column, using conditions?

I am using currently v lookup to find and place values against the specific item. however, I am looking for help for a VB macro which will out the data in defined outcome.
please see 1st screen shot of raw data
second screen shot, should be the outcome.
Please note the "site" is not constant it can be any value, so I have put all site in column A .
currently V look is doing the job well. but makes the file crash sometime.
You can solve this with a Pivot Table using your original data source with NO changes in the table layout.
Drag the columns as shown below (you'll want to rename them from the default names): For Columns, drag the Date field there first. The Σ Values field will appear after you've dragged two Fields to the Values area, and should be below Date.
And with some formatting changes from the default, the result can look like:
Can you change your source data?
If you change your data to look like the table "Changed Source Data" below you can solve your issue with a pivot table.
Solution with a Pivot Table
Changed Source Data
There question can easily solved with pivot table. For practice i have create the below.
Let us assume that:
Data appears in Sheet "Data"
Results will be populated in sheet "Results"
Option Explicit
Sub Allocation()
Dim LastRow As Long, Row As Long, Column As Long, Invetory As Long, Sold As Long, Remaining As Long, LastRowRes As Long, LastColRes As Long, CurrentCol As Long, CurrentRow As Long, i As Long, y As Long
Dim iDate As Date
Dim Site As String
Dim wsData As Worksheet, wsResults As Worksheet
Dim ExcistSite As Boolean, ExcistDate As Boolean
Set wsData = ThisWorkbook.Worksheets("Data")
Set wsResults = ThisWorkbook.Worksheets("Results")
LastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
wsResults.UsedRange.Clear
For Row = 2 To LastRow
iDate = wsData.Cells(Row, 1).Value
Site = wsData.Cells(Row, 2).Value
Invetory = wsData.Cells(Row, 3).Value
Sold = wsData.Cells(Row, 4).Value
Remaining = wsData.Cells(Row, 5).Value
If Row = 2 Then
With wsResults.Range("B1:D1")
.Merge
.Value = iDate
End With
wsResults.Range("A2").Value = "Site"
wsResults.Range("A2").Offset(1, 0).Value = Site
wsResults.Range("B2").Value = "Invetory"
wsResults.Range("B2").Offset(1, 0).Value = Invetory
wsResults.Range("C2").Value = "Sold"
wsResults.Range("C2").Offset(1, 0).Value = Sold
wsResults.Range("D2").Value = "Remaining"
wsResults.Range("D2").Offset(1, 0).Value = Remaining
Else
'Check if Site appears
LastRowRes = wsResults.Cells(wsResults.Rows.Count, "A").End(xlUp).Row
For i = 3 To LastRowRes
ExcistSite = False
If wsResults.Cells(i, 1).Value = Site Then
CurrentRow = i
ExcistSite = True
Exit For
Else
CurrentRow = i + 1
End If
Next i
If ExcistSite = False Then
wsResults.Cells(CurrentRow, 1).Value = Site
End If
'Check if date appears
LastColRes = wsResults.Cells(1, wsResults.Columns.Count).End(xlToLeft).Column
For y = 2 To LastColRes
ExcistDate = False
If wsResults.Cells(1, y).Value = iDate Then
CurrentCol = y
ExcistDate = True
Exit For
Else
CurrentCol = y + 1
End If
Next y
If ExcistDate = False Then
wsResults.Cells(2, CurrentCol + 2).Value = "Invetory"
wsResults.Cells(i, CurrentCol + 2).Value = Invetory
wsResults.Cells(2, CurrentCol + 3).Value = "Sold"
wsResults.Cells(i, CurrentCol + 3).Value = Sold
wsResults.Cells(2, CurrentCol + 4).Value = "Remaining"
wsResults.Cells(i, CurrentCol + 4).Value = Remaining
With wsResults.Range(Cells(1, LastColRes + 3), Cells(1, LastColRes + 5))
.Merge
.Value = iDate
End With
Else
wsResults.Cells(CurrentRow, CurrentCol).Value = Invetory
wsResults.Cells(CurrentRow, CurrentCol + 1).Value = Sold
wsResults.Cells(CurrentRow, CurrentCol + 2).Value = Remaining
End If
End If
Next Row
LastColRes = wsResults.Cells(1, wsResults.Columns.Count).End(xlToLeft).Column
LastRowRes = wsResults.Cells(wsResults.Rows.Count, "A").End(xlUp).Row
With wsResults.Range(Cells(1, 2), Cells(1, LastColRes))
With .Font
.Bold = True
.ThemeColor = xlThemeColorDark1
End With
With .Interior
.ThemeColor = xlThemeColorAccent1
End With
End With
With wsResults.Cells(2, 1)
With .Font
.Bold = True
.ThemeColor = xlThemeColorDark1
End With
With .Interior
.ThemeColor = xlThemeColorLight1
End With
End With
For i = 2 To LastColRes Step 3
With wsResults.Range(Cells(2, i), Cells(LastRowRes, i))
With .Interior
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.399975585192419
End With
End With
Next i
For i = 3 To LastColRes + 3 Step 3
With wsResults.Range(Cells(2, i), Cells(LastRowRes, i + 1))
With .Font
.ThemeColor = xlThemeColorDark2
.TintAndShade = -0.249977111117893
End With
End With
Next i
With wsResults.UsedRange
.Borders.LineStyle = xlContinuous
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.EntireColumn.AutoFit
End With
End Sub

Excel VBA Calendar Generator doesn't return April/June?

I borrowed code (https://github.com/BehindTheMath/vba-generate-calendar) to create a printable calendar based on a list of events ...which works great until I get to April, and June as two examples. Then, even though I have data there...the calendar doesn't return anything?
Secondly, I noticed that the recurring events wouldn't recur across the month?
The code was edited to allow for filtering, so that the calendar would simple display the filtered month graphically.
email me and I can send sample workbook with events list...couldn't figure out how to attach it?
format for events is given below in the attached image
Option Explicit
Public MaxEvents As Integer, EventsSheet As Worksheet, CalendarSheet As Worksheet, RecurringSheet As Worksheet, NumWeeks As Integer, LastDay As Integer
' Change these column numbers to reflect the Events data table
Const EventNameColumn As Integer = 1, EventStartDateColumn As Integer = 3, EventStartTimeColumn As Integer = 4
Const EventEndDateColumn As Integer = 5, EventEndTimeColumn As Integer = 6, EventDurationColumn As Integer = 7, RecurringColumn As Integer = 8, LastColumn As Integer = 11
Private Sub GenerateCalendar()
Dim FirstDayOfWeek As Integer, ThisMonth As Integer, ThisYear As Integer, DayOfWeekCounter As Integer, DateCounter As Integer, EventListRowCounter As Integer
Dim x As Integer, TopRow As Integer
Dim EventData As Variant
Dim StartDay As Date
Dim DaysEvents As Collection, Events As New Collection
Set EventsSheet = Worksheets("Events")
Set CalendarSheet = Worksheets("Calendar")
Set RecurringSheet = Worksheets("Recurring")
ThisYear = Year(EventsSheet.Cells(GetFilteredRangeTopRow, EventStartDateColumn))
ThisMonth = Month(EventsSheet.Cells(GetFilteredRangeTopRow, EventStartDateColumn))
StartDay = DateSerial(ThisYear, ThisMonth, 1)
NumWeeks = 0
' Unprotect sheet if it had a previous calendar to prevent errors.
CalendarSheet.Protect Contents:=False
' Prevent screen from flashing while drawing the calendar.
Application.ScreenUpdating = False
' Clear any previous data.
CalendarSheet.Cells.Clear
' Setup the headers
SetupHeaders StartDay
' Get on which day of the week the month starts.
FirstDayOfWeek = Weekday(StartDay)
' Get the last date of the month
LastDay = Day(DateSerial(ThisYear, ThisMonth + 1, 1) - 1)
DateCounter = 1
TopRow = 3
' If there are recurring events
If EventsSheet.Cells(GetFilteredRangeTopRow, RecurringColumn).End(xlDown) <> vbNullString Then
ParseRecurring
Set Events = LoadEvents(Worksheets("Recurring"))
Worksheets("Recurring").Cells.Clear
Else
Set Events = LoadEvents(EventsSheet)
End If
Do
For DayOfWeekCounter = FirstDayOfWeek To 7
' Write the dates
With CalendarSheet.Cells(TopRow, DayOfWeekCounter)
.Value = DateCounter
.Font.Size = 12
.Font.Bold = True
.RowHeight = 20
.HorizontalAlignment = xlRight
.IndentLevel = 1
End With
' Write events
Set DaysEvents = Nothing
' Get this day's events (if there are any)
On Error Resume Next
Set DaysEvents = Events(Str(DateCounter))
On Error GoTo 0
' If there are events on this day
If Not DaysEvents Is Nothing Then
EventListRowCounter = 0
' Go through this day's events and write them
For Each EventData In DaysEvents
EventListRowCounter = EventListRowCounter + 1
CalendarSheet.Cells(TopRow + EventListRowCounter, DayOfWeekCounter) = EventData
Next EventData
End If
DateCounter = DateCounter + 1
' If we reached the end of the month, stop.
If DateCounter > LastDay Then
NumWeeks = NumWeeks + 1
Exit Do
End If
Next DayOfWeekCounter
NumWeeks = NumWeeks + 1
FirstDayOfWeek = 1
TopRow = TopRow + MaxEvents + 1
Loop
' Set row height
For x = 1 To NumWeeks
CalendarSheet.Range(CalendarSheet.Cells(3 + x + MaxEvents * (x - 1), 1), CalendarSheet.Cells(3 + MaxEvents * x + (x - 1), 1)).RowHeight = 15
Next x
DrawBorders
' Set the print area
SetupPage
' Turn off gridlines.
ActiveWindow.DisplayGridlines = False
' Protect sheet to prevent overwriting the dates.
CalendarSheet.Protect Contents:=True, UserInterfaceOnly:=True
' Resize window to show all of calendar (may have to be adjusted
' for video configuration).
ActiveWindow.WindowState = xlMaximized
ActiveWindow.ScrollRow = 1
' Allow screen to redraw with calendar showing.
Application.ScreenUpdating = True
Set Events = Nothing: Set EventsSheet = Nothing: Set CalendarSheet = Nothing: Set DaysEvents = Nothing: Set RecurringSheet = Nothing
End Sub
Sub SetupHeaders(ByVal StartDay As Date)
Dim x As Integer
' Create the month and year title.
With CalendarSheet.Range("A1:G1")
.Merge
.Value = Format(StartDay, "mmmm yyyy")
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
.Font.Size = 18
.Font.Bold = True
.RowHeight = 35
.NumberFormat = "mmmm yyyy"
End With
' Format A2:G2 for the days of week labels.
With CalendarSheet.Range("A2:G2")
.HorizontalAlignment = xlCenter
.Font.Size = 12
.Font.Bold = True
.RowHeight = 20
.ColumnWidth = 35
End With
' Write days of week in A2:G2.
For x = 1 To 7
CalendarSheet.Cells(2, x) = WeekdayName(x)
Next x
End Sub
Sub ParseRecurring()
Dim CurDate As Integer, LastRow As Integer, OriginalLastRow As Integer, CurOriginalRow As Integer, DateCounter As Integer
LastRow = GetLastRow(EventsSheet)
OriginalLastRow = LastRow
With RecurringSheet
' Clear any old data from the Recurring sheet
.Cells.Clear
' Copy the data from the Events sheet to the Recurring sheet so we can manipulate it without affecting the original data
EventsSheet.Range("A1", .Cells(OriginalLastRow, LastColumn).Address).Copy .Range("A1")
' For each row of the original data
For CurOriginalRow = GetFilteredRangeTopRow To OriginalLastRow
' If this event is recurring
If .Cells(CurOriginalRow, RecurringColumn) <> vbNullString Then
' Get the date of the original event
CurDate = Day(.Cells(CurOriginalRow, EventStartDateColumn))
' What is the frequency that it recurs
Select Case LCase(.Cells(CurOriginalRow, RecurringColumn))
Case "daily"
' For each subsequent day
For DateCounter = CurDate To LastDay
' Copy the data
.Range(.Cells(CurOriginalRow, 1), .Cells(CurOriginalRow, RecurringColumn - 1)).Copy .Cells(LastRow + DateCounter - CurDate + 1, 1)
'Update the day to the new day
.Cells(LastRow + (DateCounter - CurDate) + 1, EventStartDateColumn) = .Cells(CurOriginalRow, EventStartDateColumn) + (DateCounter - CurDate) + 1
.Cells(LastRow + (DateCounter - CurDate) + 1, EventEndDateColumn) = .Cells(CurOriginalRow, EventEndDateColumn) + (DateCounter - CurDate) + 1
Next DateCounter
LastRow = LastRow + DateCounter - CurDate - 1
Case "weekly"
' If there are more dates to recur on
If LastDay - CurDate >= 7 Then
' For each week
For DateCounter = 7 To LastDay - CurDate Step 7
' Copy the data
.Range(.Cells(CurOriginalRow, 1), .Cells(CurOriginalRow, RecurringColumn - 1)).Copy .Cells(LastRow + (DateCounter / 7), 1)
'Update the day to the new day
.Cells(LastRow + (DateCounter / 7), EventStartDateColumn) = .Cells(CurOriginalRow, EventStartDateColumn) + DateCounter
.Cells(LastRow + (DateCounter / 7), EventEndDateColumn) = .Cells(CurOriginalRow, EventEndDateColumn) + DateCounter
Next DateCounter
LastRow = LastRow + ((DateCounter - 7) / 7)
End If
End Select
End If
Next CurOriginalRow
End With
End Sub
Function LoadEvents(ByRef sheet As Worksheet) As Collection
Dim RowCounter As Integer, CurDate As Integer, CurMonth As Integer
Dim EventData As String, LastDate As String, EventDuration As String
Dim MonthsEvents As New Collection
SortEvents sheet:=sheet
RowCounter = GetFilteredRangeTopRow
CurDate = Day(sheet.Cells(RowCounter, EventStartDateColumn))
CurMonth = Month(sheet.Cells(RowCounter, EventStartDateColumn))
LastDate = "0"
Do While sheet.Cells(RowCounter, EventStartDateColumn) <> vbNullString
' If the next event is from a different month, stop
If Month(sheet.Cells(RowCounter, EventStartDateColumn)) <> CurMonth Then Exit Do
' Get the next event
EventDuration = Format(sheet.Cells(RowCounter, EventDurationColumn), "h:mm")
' Formula for calculating duration:
'EventDuration = Int(DateDiff("n", Sheet.Cells(RowCounter, EventStartTimeColumn), Sheet.Cells(RowCounter, EventEndTimeColumn)) / 60)
'EventDuration = Event Duration & ":" & DateDiff("n", Sheet.Cells(RowCounter, EventStartTimeColumn), Sheet.Cells(RowCounter, EventEndTimeColumn)) Mod 60
EventData = sheet.Cells(RowCounter, EventNameColumn) & ": " & Format(sheet.Cells(RowCounter, EventStartTimeColumn), "h:mm AMPM") & " - "
EventData = EventData & Format(sheet.Cells(RowCounter, EventEndTimeColumn), "h:mm AMPM") & " (" & EventDuration & ")"
If LastDate <> Str(CurDate) Then
LastDate = Str(CurDate)
MonthsEvents.Add New Collection, LastDate
End If
MonthsEvents(LastDate).Add EventData
If MonthsEvents(LastDate).Count > MaxEvents Then MaxEvents = MonthsEvents(LastDate).Count
' Advance to the next row
RowCounter = RowCounter + 1
CurDate = Day(sheet.Cells(RowCounter, EventStartDateColumn))
Loop
Set LoadEvents = MonthsEvents
Set MonthsEvents = Nothing
End Function
Sub SortEvents(ByRef sheet As Worksheet)
With sheet.Sort
.SortFields.Clear
.SortFields.Add Key:=sheet.Columns(EventStartDateColumn), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=sheet.Columns(EventStartTimeColumn), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=sheet.Columns(EventEndDateColumn), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange sheet.Range(sheet.Cells(2, 1), sheet.Cells(GetLastRow(sheet), LastColumn))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Sub DrawBorders()
Dim x As Integer
' Draw outside and vertical borders
With CalendarSheet.Range(CalendarSheet.Cells(1, 1), CalendarSheet.Cells(2 + NumWeeks * (MaxEvents + 1), 7))
.Borders(xlEdgeTop).Weight = xlThick
.Borders(xlEdgeTop).ColorIndex = xlAutomatic
.Borders(xlEdgeBottom).Weight = xlThick
.Borders(xlEdgeBottom).ColorIndex = xlAutomatic
.Borders(xlRight).Weight = xlThick
.Borders(xlRight).ColorIndex = xlAutomatic
End With
With CalendarSheet.Range(CalendarSheet.Cells(1, 1), CalendarSheet.Cells(2 + NumWeeks * (MaxEvents + 1), 1))
.Borders(xlLeft).Weight = xlThick
.Borders(xlLeft).ColorIndex = xlAutomatic
End With
' Draw border above the weekday names
With CalendarSheet.Range("A2:G2")
.Borders(xlEdgeTop).Weight = xlThick
.Borders(xlEdgeTop).ColorIndex = xlAutomatic
End With
' Draw borders above and below the dates
For x = 1 To NumWeeks
With CalendarSheet.Range(CalendarSheet.Cells(3 + ((MaxEvents + 1) * (x - 1)), 1), CalendarSheet.Cells(3 + ((MaxEvents + 1) * (x - 1)), 7))
.Borders(xlEdgeTop).Weight = xlThick
.Borders(xlEdgeTop).ColorIndex = xlAutomatic
.Borders(xlEdgeBottom).Weight = xlThick
.Borders(xlEdgeBottom).ColorIndex = xlAutomatic
End With
Next x
End Sub
Sub SetupPage()
Worksheets("Calendar").Select
' Switch to Page Break Preview mode
ActiveWindow.View = xlPageBreakPreview
With CalendarSheet
' Remove old page breaks
.ResetAllPageBreaks
' Set landscape
.PageSetup.Orientation = xlLandscape
' Set page area
.PageSetup.PrintArea = .Range(.Cells(1, 1), .Cells(2 + NumWeeks * (MaxEvents + 1), 7)).Address
' Move page breaks if necessary
If .VPageBreaks.Count Then .VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
If .HPageBreaks.Count Then Set .HPageBreaks(1).Location = .Range("$A$53")
End With
' Switch back to Normal View
ActiveWindow.View = xlNormalView
End Sub
Function GetLastRow(ByRef sheet As Worksheet) As Integer
' Refresh UsedRange
'sheet.UsedRange
'GetLastRow = sheet.UsedRange.Rows(sheet.UsedRange.Rows.Count).Row
GetLastRow = sheet.Cells(1, EventNameColumn).CurrentRegion.Rows.Count
End Function
Function GetFilteredRangeTopRow() As Long
Dim HeaderRow As Long, LastFilterRow As Long
On Error GoTo NoFilterOnSheet
Range("eventlist").Activate
With ActiveSheet
HeaderRow = .AutoFilter.Range(1).Row
LastFilterRow = .Range(Split(.AutoFilter.Range.Address, ":")(1)).Row
GetFilteredRangeTopRow = .Range(.Rows(HeaderRow + 1), .Rows(Rows.Count)).SpecialCells(xlCellTypeVisible)(1).Row
If GetFilteredRangeTopRow = LastFilterRow + 1 Then GetFilteredRangeTopRow = 0
End With
NoFilterOnSheet:
End Function

For loop end variable doesn't change

I've written a very simple loop that goes through a table column and colors negative values red, positive values green and removes empty rows.
The problem occurs when rows are deleted. I update the value of the RowCount, and compensate i to check the same row again since a row was just deleted. If I have a column with 10 rows of which 2 are empty, they are deleted. I would expect the For i = 1 to RowCount to stop at 8, but it continues to 9 and produces an error because it then tries to delete the nonexistent 9th row.
What do I need to do so the loop stops at 8 instead of continuing (to I assume the initial value of the RowCount.
Sub ColourFilledCells()
Dim Table1 As ListObject
Set Table1 = ThisWorkbook.Worksheets(1).ListObjects(1)
Dim i As Lon, RowCount As Long
RowCount = Table1.ListRows.Count
For i = 1 To RowCount
If Not Table1.DataBodyRange(i, 1) = Empty Then
With Table1.DataBodyRange(i, 1)
If .Value < 0 Then
.Interior.Color = RGB(255, 0, 0)
ElseIf .Value > 0 Then
.Interior.Color = RGB(0, 255, 0)
Else
.ColorIndex = 0
End If
End With
ElseIf Table1.DataBodyRange(i, 1) = Empty Then
Table1.ListRows(i).Delete
RowCount = RowCount - 1
i = i - 1
End If
Next i
End Sub
To avoid issues with Delete affecting to For loop, count backwards.
Your code, refactored (Plus a few suggestions)
For i = RowCount to 1 Step -1
If Not isempty( Table1.DataBodyRange(i, 1)) Then
With Table1.DataBodyRange(i, 1)
If .Value < 0 Then
.Interior.Color = vbRed
ElseIf .Value > 0 Then
.Interior.Color = vbGreen
Else
.ColorIndex = xlColorIndexNone
End If
End With
Else
Table1.ListRows(i).Delete
End If
Next i
Try this code :
Sub ColourFilledCells()
Dim Table1 As ListObject
Dim uRng As Range
Set Table1 = ThisWorkbook.Worksheets(1).ListObjects(1)
Dim i As Long, RowCount As Long
RowCount = Table1.ListRows.Count
For i = 1 To RowCount
If Not Table1.DataBodyRange(i, 1) = Empty Then
With Table1.DataBodyRange(i, 1)
If .Value < 0 Then
.Interior.Color = RGB(255, 0, 0)
ElseIf .Value > 0 Then
.Interior.Color = RGB(0, 255, 0)
Else
.ColorIndex = 0
End If
End With
ElseIf Table1.DataBodyRange(i, 1) = Empty Then
If uRng Is Nothing Then
Set uRng = Table1.ListRows(i).Range
Else
Set uRng = Union(uRng, Table1.ListRows(i).Range)
End If
End If
Next i
If Not uRng Is Nothing Then uRng.Delete xlUp
End Sub

Resources