I'm trying to get number of unique ids with given values on given columns. I decided to use Scripting.Dictionary for this as follow:
Public Function getSoldToIrr(umowy As Range, bi As Range, irr As Range) As Double
Set dict = CreateObject("Scripting.Dictionary")
Dim lastRow As Long
lastRow = umowy.Rows.Count
bi_with = 0
irr_with = 0
ifff = 0 'count how many new values
elseifff = 0 'count how many duplicates
For i = 1 To lastRow
If umowy(i, 1) <> "" Then
If Not dict.Exists(umowy(i, 1)) Then ' if new id
dict(umowy(i, 1)) = Array(bi(i, 1), irr(i, 1) * bi(i, 1))
bi_with = bi_with + bi(i, 1)
irr_with = irr_with + irr(i, 1) * bi(i, 1) ' if bi and irr
ifff = ifff + 1
Else ' if found duplicate id
If dict(umowy(i, 1))(1) = 1 And bi(i, 1) = 1 Then ' if duplicate already had 1 on bi and now has bi
If dict(umowy(i, 1))(2) = 0 And irr(i, 1) = 1 Then ' if duplicate had 0 on irr but now has 1
irr_with = irr_with + irr(i, 1) * bi(i, 1)
dict(umowy(i, 1))(2) = 1
End If
ElseIf dict(umowy(i, 1))(1) = 0 And bi(i, 1) = 1 Then ' if bi was 0 and now is 1
dict(umowy(i, 1)) = Array(bi(i, 1), irr(i, 1) * bi(i, 1))
bi_with = bi_with + bi(i, 1)
irr_with = irr_with + irr(i, 1) * bi(i, 1)
End If
elseifff = elseifff + 1
End If
End If
Next i
MsgBox dict.Exists(umowy(1, 1).Value) ' returns False
MsgBox dict.Exists(dict.Keys()(0)) ' returns True
MsgBox umowy(1, 1) = dict.Keys()(0) ' returns True
MsgBox dict.Count ' returns 8000
MsgBox ifff ' returns 8000
MsgBox elseifff ' returns 0
getSoldToIrr = irr_with / bi_with
End Function
umowy is my id and those values are strings like 18/07/KOR/2020, bi and irr columns are binary columns. umowy has some duplicates but for some reason my dict takes duplicates as new keys and my code does not get into Else ' if found duplicate id.
Also if I write dict.Exists(umowy(1, 1).Value) or dict.Exists(umowy(1, 1)) I get False, but dict.Exists(dict.Keys()(0)) gives me True as umowy(1, 1) = dict.Keys()(0) and umowy(1, 1).Value = dict.Keys()(0)
What can be a reason of such behaviour?
Related
Hi I have created a workbook that uses formula to populate lists, one of which uses VBA to print labels.
My problem is the VBA sees the cell formula in blank cells and wants to print blank tags. How can I change it to see text only?
As I said, I need to edit my VBA to ignore formula and read only the resulting text.
VBA is below.
Sub Print_Labels()
Application.ScreenUpdating = False
Col_Width_1 = Range("Column_Width_1")
Col_Width_2 = Range("Column_Width_2")
Col_Width_3 = Range("Column_Width_3")
Col_Width_4 = Range("Column_Width_4")
Row_Height_1 = Range("Row_Height_1")
Row_Height_2 = Range("Row_Height_2")
Row_Height_3 = Range("Row_Height_3")
Row_Height_4 = Range("Row_Height_4")
Sheets("Equipment_List").Select
Num_Equip = Range("A1").CurrentRegion.Rows.Count
Start_Row = Range("Title_Label_Start_Row")
First_Page_YN = True
Names.Add "Equipment_List", "=" + Range("A1").Resize(Num_Equip).Address
Sheets("Labels").Select
' Set page setup
' Set column widths
For Count_Label_Columns = 1 To Num_Label_Columns
Range("A1").Offset(, (Count_Label_Columns - 1) *
4).EntireColumn.ColumnWidth = Col_Width_1
Range("B1").Offset(, (Count_Label_Columns - 1) *
4).EntireColumn.ColumnWidth = Col_Width_2
Range("C1").Offset(, (Count_Label_Columns - 1) *
4).EntireColumn.ColumnWidth = Col_Width_3
Range("D1").Offset(, (Count_Label_Columns - 1) *
4).EntireColumn.ColumnWidth = Col_Width_4
Next Count_Label_Columns
' Set row heights
For Count_Label_Rows = 1 To Num_Label_Rows
Range("A1").Offset((Count_Label_Rows - 1) * 4).EntireRow.RowHeight =
Row_Height_1
Range("A2").Offset((Count_Label_Rows - 1) * 4).EntireRow.RowHeight =
Row_Height_2
Range("A3").Offset((Count_Label_Rows - 1) * 4).EntireRow.RowHeight =
Row_Height_3
Range("A4").Offset((Count_Label_Rows - 1) * 4).EntireRow.RowHeight =
Row_Height_4
Next Count_Label_Rows
' Work out the first label row to be printed
If Start_Row > 10 Then Start_Row = 10
Count_Label_Rows = Start_Row
' Labels always start printing in the first column
Count_Label_Columns = 0
For Count_Equip = 1 To Num_Equip
' Start of new page of labels, so completely clear sheet
If First_Page_YN = True Then
Cells.Clear
First_Page_YN = False
End If
Count_Label_Columns = Count_Label_Columns + 1
If Count_Label_Columns > Num_Label_Columns Then
Count_Label_Columns = 1
Count_Label_Rows = Count_Label_Rows + 1
End If
If Count_Label_Rows > Num_Label_Rows Then
Count_Label_Rows = 1
Count_Label_Columns = 0
End If
If Count_Label_Rows = 1 And Count_Label_Columns = 0 Then
' Start of new page, so print full sheet
If Range("Title_Print_Preview") = "Print" Then
ActiveSheet.PrintOut
Else
ActiveSheet.PrintPreview
End If
Cells.Clear
Count_Label_Columns = 1
End If
Range("Title_Label_Format").Copy
Range("Labels_Top").Offset(((Count_Label_Rows - 1) * 4),
((Count_Label_Columns - 1) * 4) + 1).PasteSpecial
Range("Labels_Top").Offset(((Count_Label_Rows - 1) * 4) + 2,
((Count_Label_Columns - 1) * 4) + 2) = _
Range("Equipment_List").Offset(Count_Equip - 1).Resize(1, 1)
' Enter the sequence number of the equipment
Range("Labels_Top").Offset(((Count_Label_Rows - 1) * 4),
((Count_Label_Columns - 1) * 4) + 3) = Count_Equip
Next Count_Equip
' Print or Preview the last sheet
If Range("Title_Print_Preview") = "Print" Then
ActiveSheet.PrintOut
Else
ActiveSheet.PrintPreview
End If
Application.ScreenUpdating = True
End Sub
-------------------------------------------------------------------------------
I am trying to add a variable number of items to a string array.
My code is in a worksheet change function:
Dim StartNums(0 To 2) As String
doneColor = RGB(175, 175, 175)
cmt = FRg.Comment.Text
rowLen = InStr(1, cmt, vbLf)
If rowLen = 0 Then
rowLen = Len(cmt)
End If
numChunks = rowLen / 32
numRows = Len(cmt) / rowLen
' For i = 1 To 12 'FRg.Comment.Shape.TextFrame.Characters.Count
' With FRg.Comment.Shape.TextFrame.Characters(i, 1)
' If .Font.Strikethrough = True Then
' .Font.Color = vbGreen
' End If
' End With
' Next i
MsgBox ("About to fill StartNums, nothing should be in it yet")
For j = 0 To numChunks - 1
MsgBox ("going to add stuff for chunk " & j)
If Not UBound(StartNums) = 2 Then
' MsgBox ("resizing an empty array")
' ReDim Preserve StartNums(3) As Variant
' Else
'MsgBox ("resizing a non-empty array")
ReDim Preserve StartNums(UBound(StartNums) + 3) As String
End If
StartNums(UBound(StartNums) - 2) = (j * 32) + 5 + (0 * 9)
StartNums(UBound(StartNums) - 1) = (j * 32) + 5 + (1 * 9)
StartNums(UBound(StartNums) - 0) = (j * 32) + 5 + (2 * 9)
Next j
Now whenever I go into the worksheet, the ReDim line has a Compile Error Array already dimensioned. I'm aware it's already dimensioned, which is why I'm ReDim-ing it.
How do I add 3 more spaces in an array?
When you initially Dim it, you can't give it the size if you plan on changing the size later:
so instead of
Dim StartNums(0 To 2) As String
You would use
Dim StartNums() As String
and then on the next line
ReDim StartNums(0 To 2)
note, you can also use this, as it's assumed to be 0 based by default.
ReDim StartNums(2)
That will accomplish the same thing, but then you can later use Redim Preserve to change the size of it.
I have an excel table where there are part codes in a column and for every part code, there are 3-4 subsections (1100-1400) with information which I need to attach to the part code in a column view.
The number of created rows depends on if there is data entered into subsection 1400. 1100-1300 has always information and needs to be converted into a table.
I don't even know from where to start so currently I have no code to show
I added a picture of how the data is represented and what the result should look like:
You could do it like that
Option Explicit
Sub TransformA()
Dim rg As Range
Dim lastRow As Long, lineNo As Long, i As Long, j As Long
Dim shInput As Worksheet, shResult As Worksheet
Dim vDat As Variant, resDat As Variant
Dim subSection As String
' Make sure you run the code with the data in the Activesheet
Set shInput = ActiveSheet
' And you have data which starts in row 4 with the heading in row 3
' otherwise adjust accordingly
lastRow = shInput.Range("A4").End(xlDown).Row
Set rg = shInput.Range("A4:I" & lastRow)
vDat = rg
ReDim resDat(1 To UBound(vDat, 1) * 4, 1 To 4)
lineNo = 1
For j = 1 To UBound(vDat, 1)
For i = 0 To 2
Select Case i
Case 0: subSection = "1100"
Case 1: subSection = "1200"
Case 2: subSection = "1300"
End Select
resDat(lineNo + i, 1) = vDat(j, 1)
resDat(lineNo + i, 2) = subSection
resDat(lineNo + i, 3) = vDat(j, 2 + 2 * i)
resDat(lineNo + i, 4) = vDat(j, 3 + 2 * i)
Next
i = 3
subSection = "1400"
If Len(vDat(j, 2 + 2 * i)) = 0 And Len(vDat(j, 3 + 2 * i)) = 0 Then
lineNo = lineNo + 3
Else
resDat(lineNo + i, 1) = vDat(j, 1)
resDat(lineNo + i, 2) = subSection
resDat(lineNo + i, 3) = vDat(j, 2 + 2 * i)
resDat(lineNo + i, 4) = vDat(j, 3 + 2 * i)
lineNo = lineNo + 4
End If
Next
' Output the result to a new sheet
Set shResult = Sheets.Add
With shResult
.Cells(1, 1).Value = "Part Code"
.Cells(1, 2).Value = "Subsection"
.Cells(1, 3).Value = "Time"
.Cells(1, 4).Value = "Text"
End With
shResult.Range("A2").Resize(UBound(resDat, 1), 4) = resDat
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
Function calculateIO(ByVal reachName As String, ByVal natFlow As Double, ByVal IOTableWorksheet As Worksheet, ByVal weeklyDate As Date) As Double
Dim rowNoReach, rowToNextTable, columnNo, rowNo, startColumn, columnCounter, rowCounter, rowCounter1, dateCounter As Integer
Dim vlookupRange As Range
Dim vlookupResult As Double
Dim currentDay, currentMonth As Integer
Dim differenceCal As Double
Dim ansStorage 'where to store the natural flow value from the IO table that is used to obtain the corresponding IO
Dim IOvalue As Double
differenceCal = 1000000
currentDay = day(weeklyDate)
currentMonth = month(weeklyDate)
'Format the reach name if it is a mainstem reach name.
If (InStr(reachName, "Mainstem") > 0) Then reachName = Trim(Split(reachName, "-")(1))
'Initializes the row pointers
rowNoReach = 0
rowToNextTable = 1
startColumn = 1
'It is assumed that there is no IO until one is found
calculateIO = -1
'Loop through each IO table until there an IO table is not found
Do While (rowToNextTable <> 0)
rowNoReach = rowNoReach + rowToNextTable
rowToNextTable = IOTableWorksheet.Cells(rowNoReach, 14).value
'This will compare the reach name with the IO table name. if they are a match then an IO will be calculated using this IO table.
If (InStr(IOTableWorksheet.Cells(rowNoReach, 2).value, reachName) > 0) Then
If ((currentMonth <= 3) Or (currentMonth >= 11)) Then
columnCounter = 1
For columnCounter = 1 To 21
If ((month(IOTableWorksheet.Cells(rowNoReach + 2, columnCounter)) = currentMonth) And (day(IOTableWorksheet.Cells(rowNoReach + 2, i)) = currentDay)) Then
calculateIO = IOTableWorksheet.Cells(rowNoReach + 3, columnCounter).value
Exit Function
End If
Next columnCounter
'looking through the table
ElseIf ((currentMonth >= 4) Or (currentMonth <= 10)) Then
columnCounter = 1
Do While IsDate(IOTableWorksheet.Cells(rowNoReach + 5, columnCounter))
If ((day(weeklyDate) = day(IOTableWorksheet.Cells(rowNoReach + 5, columnCounter))) And (month(weeklyDate) = month(IOTableWorksheet.Cells(rowNoReach + 5, columnCounter)))) Then
startColumn = columnCounter
End If
columnCounter = columnCounter + 1
Loop
If (natFlow < IOTableWorksheet.Cells(rowNoReach + 6, startColumn)) Then
calculateIO = natFlow
Exit Function
ElseIf (natFlow > IOTableWorksheet.Cells(rowNoReach + 6, startColumn)) Then
rowCounter1 = 0
For rowCounter1 = 0 To IOTableWorksheet.Range(IOTableWorksheet.Cells(rowNoReach + 6, startColumn), IOTableWorksheet.Range(IOTableWorksheet.Cells(rowNoReach + 6, startColumn).End(xlDown))).Rows.Count - 1
If (difference > (natFlow - IOTableWorksheet.Cells(rowNoReach + rowCounter1, startColumn))) Then
If (natFlow - IOTableWorksheet.Cells(rowNoReach + rowCounter1, startColumn)) < 0 Then
calculateIO = IOvalue
Exit Function
End If
difference = natFlow - IOTableWorksheet.Cells(rowNoReach + rowCounter1, startColumn)
IOvalue = IOTableWorksheet.Cells(rowNoReach + rowCounter1, 32)
End If
calculateIO = IOvalue
Exit Function
End If
End If
ElseIf (IOTableWorksheet.Cells(rowNoReach, 2).value = "Minimum Or Established IO") Then
'Initialize row and column pointers
rowNo = rowNoReach + 3
columnNo = 2
'Calculate the row and column number
Do While (InStr(reachName, IOTableWorksheet.Cells(rowNoReach + 2, columnNo).value) = 0 And Not IsEmpty(IOTableWorksheet.Cells(rowNoReach + 2, columnNo).value)): columnNo = columnNo + 1: Loop
Do While (month(IOTableWorksheet.Cells(rowNo, 1).value) <> month(weeklyDate) Or day(IOTableWorksheet.Cells(rowNo, 1).value) <> day(weeklyDate)): rowNo = rowNo + 1: Loop
'Get the IO value from the table if the reach was in the table
If Not IsEmpty(IOTableWorksheet.Cells(rowNo, columnNo).value) Then calculateIO = IOTableWorksheet.Cells(rowNo, columnNo): Exit Function
ElseIf (IOTableWorksheet.Cells(rowNoReach, 2).value = "Single IO Streams") Then
'Initialize row and column pointers
rowNo = rowNoReach + 3
columnNo = 2
'Calculate the column number
Do While InStr(reachName, IOTableWorksheet.Cells(rowNoReach + 2, columnNo).value) = 0 And Not IsEmpty(IOTableWorksheet.Cells(rowNoReach + 2, columnNo).value): columnNo = columnNo + 1: Loop
'Get the IO value from the table if the reach was in the table
If Not IsEmpty(IOTableWorksheet.Cells(rowNo, columnNo).value) Then calculateIO = IOTableWorksheet.Cells(rowNo, columnNo): Exit Function
End If
Loop 'looping through the first do while loop
End Function
no idea why the code keeps on having this compiling error, I have basically looked through by identifying each End If statement with the corresponding If-ElseIF-Else statement and no extra End If should be in here. Also I have properly indented the code.