I wanted to ask waht am i doing wrong here ?? i want the VLookup to find if the ProjectID is already there , and if it is, I want it to skip the registering step and immediately go to Next Row_T to see the next row of data , whenever i start the error " Application-defined or object-defined error " comes up on the line :
Repetition = Application.WorksheetFunction.VLookup(Worksheets(NBG_RegionaDataWorksheetName).Cells(Row_T, ProjectID).Value, Worksheets(Issue_SumofSharesWorksheetName).Range("A2:AS"), 1)
i don't know what is wrong , can you please help me ??
For Row_S = 2 To MAX_Row_S
SourceYear = Worksheets(NBG_SourceRegionDataWorksheetName).Cells(Row_S, SOP).Value
SourceYear = DatePart("yyyy", SourceYear)
SourceCarmaker = Worksheets(NBG_SourceRegionDataWorksheetName).Cells(Row_S, carmaker).Value
SourceProject = Worksheets(NBG_SourceRegionDataWorksheetName).Cells(Row_S, Project).Value
SourceFamily = Worksheets(NBG_SourceRegionDataWorksheetName).Cells(Row_S, Family).Value
SourceStatus = Worksheets(NBG_SourceRegionDataWorksheetName).Cells(Row_S, Status).Value
SourceShare = Worksheets(NBG_SourceRegionDataWorksheetName).Cells(Row_S, Share).Value
SourceCst = Worksheets(NBG_SourceRegionDataWorksheetName).Cells(Row_S, "A").Value
SourcePID = Worksheets(NBG_SourceRegionDataWorksheetName).Cells(Row_S, ProjectID).Value
' Take the data from NBG_Data_Region sheet to be Sourceared with each row of the NBG_Data_Source_Region sheet
For Row_T = 2 To MAX_Row_T
If Row_T >= MAX_Row_T Then
Exit For
End If
'NBGMonth = Worksheets(NBG_RegionaDataWorksheetName).Cells(Row_T, SOP).Value
'NBGMonth = DatePart("m", NBGMonth)
NBGYear = Worksheets(NBG_RegionaDataWorksheetName).Cells(Row_T, SOP).Value
NBGYear = DatePart("yyyy", NBGYear)
NBGCarmaker = Worksheets(NBG_RegionaDataWorksheetName).Cells(Row_T, carmaker).Value
NBGProject = Worksheets(NBG_RegionaDataWorksheetName).Cells(Row_T, Project).Value
NBGFamily = Worksheets(NBG_RegionaDataWorksheetName).Cells(Row_T, Family).Value
NBGStatus = Worksheets(NBG_RegionaDataWorksheetName).Cells(Row_T, Status).Value
NBGShare = Worksheets(NBG_RegionaDataWorksheetName).Cells(Row_T, Share).Value
NBGCst = Worksheets(NBG_RegionaDataWorksheetName).Cells(Row_T, "A").Value
NBGPID = Worksheets(NBG_RegionaDataWorksheetName).Cells(Row_T, ProjectID).Value
'Get the number of rows in Issue_SumofShares
'SoS = SumofShares
MAX_Row_inSoS = Worksheets(Issue_SumofSharesWorksheetName).UsedRange.RowS.Count
S = MAX_Row_inSoS
Repetition = Application.WorksheetFunction.VLookup(Worksheets(NBG_RegionaDataWorksheetName).Cells(Row_T, ProjectID).Value, Worksheets(Issue_SumofSharesWorksheetName).Range("A2:AS"), 1)
' StatusBar Show
Application.StatusBar = "VerifySumofShares. Progress: " & Row_S & " of " & MAX_Row_S
'Check if any row with a SOP date in the previous or current years and if it is a D-IN or OPP is found and add it to the IssueSOP_Date sheet
' NAF 20161208
'Test with Source of YEAR and MONTH
' If (NBGMonth = SourceMonth And NBGYear = SourceYear And SourceCarmaker = NBGCarmaker And SourceProject = NBGProject And SourceFamily = NBGFamily And SourceShare + NBGShare <> 1 And NBGCst <> SourceCst) Then
' With Year only
If (NBGYear = SourceYear And SourceCarmaker = NBGCarmaker And SourceProject = NBGProject And SourceFamily = NBGFamily And SourceShare + NBGShare <> 1 And NBGCst <> SourceCst) Then
If IsError(Repetition) = False Then
GoTo Line1
Else: GoTo Line2
End If
Line2:
'Customization of the Issue_SumofShares sheet to show the NBG Data Row , Cst, SOP , Product, Responsible,Family , Carmaker , Share , Status and the GeoRegion of the data which the condition applies to
Worksheets(Issue_SumofSharesWorksheetName).Cells(3 + Issue_SumofSharesCnt, "A").Value = Worksheets(NBG_RegionaDataWorksheetName).Cells(Row_T, ProjectID).Value
Worksheets(Issue_SumofSharesWorksheetName).Cells(3 + Issue_SumofSharesCnt, "B").Value = Worksheets(NBG_RegionaDataWorksheetName).Cells(Row_T, Customer).Value
Worksheets(Issue_SumofSharesWorksheetName).Cells(3 + Issue_SumofSharesCnt, "C").Value = GetMonthAndQuarter(Worksheets(NBG_RegionaDataWorksheetName).Cells(Row_T, SOP).Value)
Worksheets(Issue_SumofSharesWorksheetName).Cells(3 + Issue_SumofSharesCnt, "D").Value = Worksheets(NBG_RegionaDataWorksheetName).Cells(Row_T, Product).Value
Worksheets(Issue_SumofSharesWorksheetName).Cells(3 + Issue_SumofSharesCnt, "E").Value = Worksheets(NBG_RegionaDataWorksheetName).Cells(Row_T, Family).Value
Worksheets(Issue_SumofSharesWorksheetName).Cells(3 + Issue_SumofSharesCnt, "F").Value = Worksheets(NBG_RegionaDataWorksheetName).Cells(Row_T, Project).Value
Worksheets(Issue_SumofSharesWorksheetName).Cells(3 + Issue_SumofSharesCnt, "G").Value = Worksheets(NBG_RegionaDataWorksheetName).Cells(Row_T, carmaker).Value
Worksheets(Issue_SumofSharesWorksheetName).Cells(3 + Issue_SumofSharesCnt, "H").Value = Worksheets(NBG_RegionaDataWorksheetName).Cells(Row_T, Share).Value
Worksheets(Issue_SumofSharesWorksheetName).Cells(3 + Issue_SumofSharesCnt, "I").Value = Worksheets(NBG_RegionaDataWorksheetName).Cells(Row_T, Responsible).Value
Worksheets(Issue_SumofSharesWorksheetName).Cells(3 + Issue_SumofSharesCnt, "K").Value = Worksheets(NBG_RegionaDataWorksheetName).Cells(Row_T, Status).Value
Worksheets(Issue_SumofSharesWorksheetName).Cells(3 + Issue_SumofSharesCnt, "L").Value = Worksheets(NBG_RegionaDataWorksheetName).Cells(Row_T, "BO").Value
' Region As String
Region = ""
'Add any other GeoRegion which is also responsible in the recorded data
If Worksheets(NBG_DataWorksheetName).Cells(Row_T, "BC") Then
Region = Region + "#EMEA"
End If
If Worksheets(NBG_DataWorksheetName).Cells(Row_T, "BD") Then
Region = Region + "#AMERICAS"
End If
If Worksheets(NBG_DataWorksheetName).Cells(Row_T, "BE") Then
Region = Region + "#GCSA"
End If
If Worksheets(NBG_DataWorksheetName).Cells(Row_T, "BF") Then
Region = Region + "#JAPAN&KOREA"
End If
Worksheets(Issue_SumofSharesWorksheetName).Cells(3 + Issue_SumofSharesCnt, "J").Value = Region
'Count the number of the cases recorded
Issue_SumofSharesCnt = Issue_SumofSharesCnt + 1
'If there is no items , the Message to show
ElseIf (Worksheets(NBG_SourceRegionDataWorksheetName).Cells(Row_S, SOP).Value = "There are no items to show in this view.") Then
End If
Line1:
Next Row_T
Next Row_S
Repetition = Application.WorksheetFunction.VLookup( _
Worksheets(NBG_RegionaDataWorksheetName).Cells(Row_T, ProjectID).Value, _
Worksheets(Issue_SumofSharesWorksheetName).Range("A2:AS"), 1)
This will throw a run-time error if the value being looked up is not found. Safer to use this approach:
Repetition = Application.VLookup(...)
If Not IsError() Then
'was found
Else
'not found
End If
Omitting the WorksheetFunction means the function will instead return an error value which you can test for. Also, you should always include the last argument Falseto VLookup unless you really want the default behavior.
As a side note, your code will be significantly more readable if you use variables to refer to your sheets instead repeating the full path every time:
Dim wsISOS As Worksheet
Set wsISOS = Worksheets(Issue_SumofSharesWorksheetName)
Related
I am getting an error in the macro I'm working on for a bootcamp project. The idea is that I have refactored the code to make it more efficient, but I'm getting an Overflow error on one of the lines. I think it's due to it trying to divide 0, but I don't know where I've gone wrong in the loop that it is pulling data that would divide by 0. Any ideas? I'm getting the error on this line
Cells(4 + i, 3).Value = EndingPrices(i) / StartingPrices(i) - 1
in section 4 - '4) Loop through your arrays to output the Ticker, Total Daily Volume, and Return.
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 Stocks 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 Integer
tickerIndex = 0
'1b) Create three output arrays
Dim tickerVolumes(12) As Long
Dim StartingPrices(12) As Long
Dim EndingPrices(12) As Long
''2a) Create a for loop to initialize the tickerVolumes to zero.
For i = 0 To 11
tickerVolumes(i) = 0
Next i
''2b) Loop over all the rows in the spreadsheet.
For i = 2 To RowCount
'3a) Increase volume for current ticker
If Cells(i, 1).Value = tickerIndex Then
tickerVolumes(tickerIndex) = tickerVolumes(tickerIndex) + Cells(i, 8).Value
End If
'3b) Check if the current row is the first row with the selected tickerIndex.
'If Then
If Cells(i, 1) = tickerIndex And Cells(i - 1, 1).Value <> tickerIndex Then
StartingPrices(tickerIndex) = Cells(i, 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(i, 1).Value = tickerIndex And Cells(i + 1, 1) <> tickerIndex Then
EndingPrices(tickerIndex) = Cells(i, 6).Value
'3d Increase the tickerIndex.
tickerIndex = tickerIndex + 1
End If
'End If
Next i
'4) Loop through your arrays to output the Ticker, Total Daily Volume, and Return.
For i = 0 To 11
Worksheets("All Stocks Analysis").Activate
tickerIndex = i
Cells(4 + i, 1).Value = tickers(i)
Cells(4 + i, 2).Value = tickerVolumes(i)
Cells(4 + i, 3).Value = EndingPrices(i) / StartingPrices(i) - 1 ' **this line is causing the error**
Next i
'Formatting
Worksheets("All Stocks 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
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
So I have this code that sets object properties of a class in a for loop, saving each object as an element in an array, BREobjects(). The very next code is below and the first BREobjects(i).BREdays is throwing an
Object variable not set error.
It's a Public array so it shouldn't need to be redim'ed or anything. Anyone know what's happening?
Code that sets the object properties:
'creates a new object for each BRE day/time combination
count = 0
For Each i In BREitems
BREdaysString = Split(Cells(i.Row, "c").value, ", ")
For j = LBound(BREdaysString) To UBound(BREdaysString)
count = count + 1
ReDim Preserve BREobjects(count)
Set BREobjects(count) = New BREpptObjects
BREobjects(count).BREname = Cells(i.Row, "a").value
BREobjects(count).BREcategory = Cells(i.Row, "b").value
BREobjects(count).BREstartTime = Cells(i.Row, "d").value
BREobjects(count).BRElength = Cells(i.Row, "e").value
BREobjects(count).BREtimeRight = Right(Cells(i.Row, "d").value, 2)
BREobjects(count).BREdays = BREdaysString(j)
'Sets the start row number accounting for BREs that start on the half hour
If BREobjects(count).BREtimeRight = 0 Then
BREobjects(count).BREstartRow = (Cells(i.Row, "d").value / 100) + 3
BREobjects(count).BREremainder = 0
ElseIf BREobjects(count).BREtimeRight <> 0 Then
BREobjects(count).BREstartRow = ((Cells(i.Row, "d").value - BREobjects(count).BREtimeRight) / 100) + 3
BREobjects(count).BREremainder = 1
End If
'determines the row the BRE ends in
If BREobjects(count).BRElength - Fix(BREobjects(count).BRElength) = 0 Then
BREobjects(count).BREendRow = BREobjects(count).BREstartRow + BREobjects(count).BRElength - 1
ElseIf BREobjects(count).BRElength - Fix(BREobjects(count).BRElength) > 0 Or BREobjects(count).BREremainder = 1 Then
BREobjects(count).BREendRow = BREobjects(count).BREstartRow + Fix(BREobjects(count).BRElength)
End If
If BREobjects(count).BREremainder = 1 And BREobjects(count).BRElength >= 1 Then
BREobjects(count).BREendRow = BREobjects(count).BREendRow + 1
End If
'sets the end time
If BREobjects(count).BRElength - Fix(BREobjects(count).BRElength) = 0 Then
BREobjects(count).BREendTime = BREobjects(count).BREstartTime + (100 * BREobjects(count).BRElength)
ElseIf BREobjects(count).BRElength - Fix(BREobjects(count).BRElength) > 0 Then
BREtimeRight = Right(BREobjects(count).BRElength, 2)
BREobjects(count).BREendTime = BREobjects(count).BREstartTime + (100 * Fix(BREobjects(count).BRElength)) + (BREtimeRight * 60)
End If
BREobjects(count).BREID = BREobjects(count).BREname & " " & BREobjects(count).BREdays & " " & _
BREobjects(count).BREstartTime & " " & BREobjects(count).BREendTime & " " & BREobjects(count).BRElength
Next j
Erase BREdaysString
Next i
'This loop throws an Object variable or with block variable not set error.
'Thrown on the array in the line BREdays = BREobjects(i).BREdays.
Back:
For i = LBound(BREobjects) To UBound(BREobjects)
Dim BREdays As String
BREdays = BREobjects(i).BREdays
If FiveDay = True And BREdays = "Saturday" Or BREdays = "Sunday" Then
Call DeleteElement(i, BREobjects()) 'Deletes the BREppt Object from the BREobjects array
ReDim Preserve BREobjects(UBound(BREobjects) - 1) 'Shrinks the array by one, removing the last one
GoTo Back 'Restarts the loop because the UBound has changed
End If
Debug.Print BREobjects(i).BREID
Next i
If you were to refactor you code using a collection and move some of the property setting to the class module it could reduce the code to something like this.
Sub ExportToPPTButton_Click()
Dim wb As Workbook, ws As Worksheet, iLastRow As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
iLastRow = ws.Cells(Rows.count, 1).End(xlUp).Row
Dim BREobjects As New Collection
Dim obj As BREpptObjects2, arDays As Variant
Dim i As Long, dow As Variant, sKey As String, s As String
Dim FiveDays As Boolean
' dictionary to count multiple day/time
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
FiveDays = True
For i = 5 To iLastRow
s = ws.Cells(i, "D")
s = Replace(s, " ", "") 'remove spaces
arDays = Split(s, ",")
For Each dow In arDays
s = LCase(Left(dow, 3))
If (FiveDays = True) And (s = "sat" Or s = "sun") Then
' skip weekends
Else
Set obj = New BREpptObjects2
obj.BREDays = dow
obj.initialise ws.Cells(i, 1)
' avoid duplicate day/time
sKey = obj.BREDays & obj.BREstartTime
obj.BREpic = dict(sKey) + 0
dict(sKey) = dict(sKey) + 1
' add to collection
BREobjects.Add obj, obj.BREID
End If
Next
Next
' set total objects in cell
For Each obj In BREobjects
sKey = obj.BREDays & obj.BREstartTime
obj.BREobjInCell = dict(sKey)
Next
MsgBox BREobjects.count & " objects added to collection"
For Each obj In BREobjects
obj.dump ' debug.print objects
Next
End Sub
Note : I used Public here for demo but use Private in your code
' class BREpptObjects2
Public BREname As String, BRElocation As String, BREcategory As String
Public BREstartTime As String, BREendTime As String
Public BRElength As Double
Public BREDays As String, BREID As String, BREStartRow, BREEndRow
Public BREobjInCell As Integer, BREpic As Integer
Sub initialise(rng As Range)
Dim StartHour As Integer, StartMin As Integer
Dim DurHour As Integer, DurMin As Integer
Dim EndHour As Integer, EndMin As Integer
With rng
BREname = .Offset(0, 0).Value ' A
BRElocation = .Offset(0, 1).Value 'B
BREcategory = .Offset(0, 2).Value 'C
BREstartTime = .Offset(0, 4).Value 'E
BRElength = .Offset(0, 5).Value 'F
End With
StartHour = Int(BREstartTime / 100)
StartMin = BREstartTime Mod 100
DurHour = Fix(BRElength)
DurMin = (BRElength - DurHour) * 60
' set end time
EndHour = StartHour + DurHour
EndMin = StartMin + DurMin
If EndMin > 60 Then
EndMin = EndMin - 60
EndHour = EndHour + 1
End If
BREendTime = EndHour * 100 + EndMin
'Sets the start row number accounting for BREs that start on the half hou
BREStartRow = StartHour + 3
BREEndRow = EndHour + 3
BREID = BREname & " " & BREDays & " " & _
BREstartTime & " " & BREendTime & " " & BRElength
End Sub
Sub dump()
Debug.Print "ID [" & BREID & "]"
Debug.Print "StartTime", BREstartTime, "End TIme", BREendTime, "Length", BRElength
Debug.Print "StartRow", BREStartRow, "EndRow", BREEndRow
Debug.Print "pic", BREpic, "objInCell", BREobjInCell
End Sub
Im trying to get the row number back after matching the user input via Vlook up this is meant to be used in the process of pulling items into a custom userform for editing. How should i return this Row number.
Here is my code for this.
Sub Sheet1_Button2_Click()
Dim Vall As String
Vall = InputBox("Enter Refernce #", Find & Edit)
Vall2 = Application.VLookup(Vall, 11, K1)
MsgBox "found" & Application.Row(Vall2)
Vall3 = Vall2.Rows
UserForm1.TextBox1 = Sheets(1).Range("A" + Vall3).Text
UserForm1.TextBox2 = Sheets(1).Range("B" + Vall3).Text
UserForm1.TextBox3 = Sheets(1).Range("C" + Vall3).Text
UserForm1.TextBox4 = Sheets(1).Range("D" + Vall3).Text
UserForm1.TextBox5 = Sheets(1).Range("E" + Vall3).Text
UserForm1.TextBox6 = Sheets(1).Range("J" + Vall3).Text
UserForm1.TextBox12 = Sheets(1).Range("K" + Vall3).Text
UserForm1.TextBox7 = Sheets(1).Range("M" + Vall3).Text
UserForm1.TextBox8 = Sheets(1).Range("N" + Vall3).Text
UserForm1.TextBox10 = Sheets(1).Range("O" + Vall3).Text
UserForm1.TextBox11 = Sheets(1).Range("P" + Vall3).Text
UserForm1.Show
End Sub
I did a vb code which is reading multiple text files from a folder and then parsing specific data from it. In the code I have hard coded a folderpath strPath = "C:\Users\smim\Desktop\Mim\Excel\". Now I would like to be able to choose the folder and files manually instead of hard coding the folder path. Here is my code :
Sub Parse()
Dim ws As Worksheet
Dim MyData As String, strData() As String
Dim WriteToRow As Long, i As Long
Dim strCurrentTxtFile As String
Dim count As Variant, yellow As Variant, red As Variant,
Dim YellowC As Variant,RedC As Variant, filecounter As Variant
Dim strPath As String
Application.ScreenUpdating = False
count = 0
red = 0
yellow = 0
YellowC = 0
RedC = 0
strPath = "C:\Users\smim\Desktop\Mim\Excel\"
'Set Book3 = Sheets("Sheet1")
Set ws = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
MsgBox ("Started")
'~~> Start from Row 1
'WriteToRow = 1
Cells(3, 1) = "Error"
Cells(3, 1).Interior.ColorIndex = 3
Cells(3, 2) = "Warnings"
Cells(3, 2).Interior.ColorIndex = 6
Cells(1, 3) = "Error"
Cells(1, 3).Interior.ColorIndex = 3
Cells(2, 3) = "Warnings"
Cells(2, 3).Interior.ColorIndex = 6
strCurrentTxtFile = Dir(strPath & "test_*.txt")
' MsgBox (strCurrentTxtFile)
'~~> Looping through all text files in a folder
Do While strCurrentTxtFile <> ""
Dim list() As String
'~~> Open the file in 1 go to read it into an array
Open strPath & strCurrentTxtFile For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
strData() = Split(MyData, vbLf)
LineCount = UBound(strData)
' MsgBox (LineCount)
'Assigning length of the list array
ReDim Preserve list(LineCount + 1)
For x = 0 To (LineCount - 1)
'For x = LBound(strData) To UBound(strData)
'Parsing each line to get the result only ( after = sign)
s = Split(strData(x), "=")
b = UBound(s)
'MsgBox (s(1))
'Assigning Values to the list array
list(x) = s(1)
Next
'MsgBox ("This is list" & list(2))
'Active Cell 2
Range("A2").Activate
'Get row number
dblRowNo = ActiveCell.Row
'Get col number
dblColNo = ActiveCell.Column
'MsgBox (dblColNo)
' ReDim Preserve list(LineCount)
For i = 0 To (LineCount - 1)
Cells(3, 3 + i + 1).Value = i
'Looping and assigning Values to the Cell
'For i = LBound(strData) To UBound(strData)
tempParsing = Split(list(i), ":")
' MsgBox (tempParsing(0))
If tempParsing(0) > 0 And tempParsing(0) < 10 Then
Cells(dblRowNo + count + 2, dblColNo + i + 3).Interior.ColorIndex = 6
yellow = yellow + 1
ElseIf tempParsing(0) >= 10 Then
Cells(dblRowNo + count + 2, dblColNo + i + 3).Interior.ColorIndex = 3
red = red + 1
ElseIf tempParsing(0) = 0 Then
Cells(dblRowNo + count + 2, dblColNo + i + 3).Interior.ColorIndex = 0
End If
'Looping and assigning Values to the Cell
' For i = LBound(strData) To UBound(strData)
Cells(dblRowNo + count + 2, dblColNo + 1) = yellow
Cells(dblRowNo + count + 2, dblColNo) = red
Cells(dblRowNo + count + 2, dblColNo + i + 3).Value = list(i)
Next
Cells(3 + count + 1, 3).Value = count
count = count + 1
yellow = 0
red = 0
strCurrentTxtFile = Dir
Loop
For t = 4 To 175
If Cells(t, 1).Value > 0 Then
Cells(t, 1).Interior.ColorIndex = 3
End If
If Cells(t, 2).Value > 0 Then
Cells(t, 2).Interior.ColorIndex = 6
End If
Next
'Cells(9, 1) = "linecount = "
'Cells(9, 2) = LineCount
MsgBox "Done"
For f = 4 To 175
If Cells(f, 4).Interior.ColorIndex = 6 Then
YellowC = YellowC + 1
ElseIf Cells(f, 4).Interior.ColorIndex = 3 Then
RedC = RedC + 1
End If
Next
For g = 4 To 175
If Cells(g, 7).Interior.ColorIndex = 6 Then
YellowC = YellowC + 1
ElseIf Cells(g, 7).Interior.ColorIndex = 3 Then
RedC = RedC + 1
End If
Next
For u = 0 To (LineCount - 1)
Cells(dblRowNo, dblColNo + u + 3) = YellowC
Cells(1, dblColNo + u + 3) = RedC
Next
YellowC = 0
RedC = 0
Application.ScreenUpdating = True
End Sub