I am trying to make a Bill of Material list from my CAD software(Creo), this is exported out as a text file and its almost working perferct. The problem is that the text file spits out all parts in model, and I would like to count up duplicates instead of list them out after each other i.e quanties larger then 1.
My code does this nicely if the duplicate is listed in the row above, however if its nested(sub assy) this does not work. In picture below 00151564.asm(level 2) should be listed as quantity=3 but the parts on level 3 should be listed as quantity=1
Below is the original textfile creo spitts out, groups and patterns makes extra unwanteded indents, and material is just sometimes given..
Here is my code:
Sub simen2(Optional myFile As String = "Z:\Prosjekt\33907\Equipment and
materials\Structure\treetool2.txt")
Dim text As String
Dim textline As String
Dim textlineTemp As String
Dim foo As String
Dim output As String
Dim parent As String
Dim grandma As String
Dim greatgrandma As String
Dim greatgreatgrandma As String
Dim partNumber As String
Dim quantity As Integer
Dim material As String
Dim wsOut As Worksheet
Dim i, k As Long
Dim level, levelOld, levelTemp, levelTempOld, subtractLevel As Integer
Dim duplicate As Boolean
Dim levelDictionary As Object
'Init variables
Set wsOut = ThisWorkbook.Worksheets("Output")
subtractLevel = 0
quantity = 1
duplicate = True
partNumberOld = ""
commonNameOld = ""
levelOld = 0
levelTemp = 0
levelTempOld = 0
materialOld = ""
textlineOld = ""
material = "NA"
materialOld = "NA"
text = wsOut.Cells(1, 1).Value
wsOut.Cells.ClearContents
wsOut.Cells(1, 1).Value = text
wsOut.Cells(1, 2).Value = Now
wsOut.Cells(1, 3).Value = myFile
Call write2ExcelHeader(wsOut)
Set levelDictionary = CreateObject("Scripting.Dictionary")
i = 0
k = 1
FileNum = FreeFile()
Open myFile For Input As #FileNum
Line Input #FileNum, foo
Line Input #FileNum, foo
Do Until EOF(FileNum)
k = k + 1
' read in
Line Input #FileNum, textline
' Get level, however group and pattern fuck things up
If InStr(10, textline, "<HTML>") > 0 Or InStr(textline, "Pattern") > 0 Or InStr(textline, "Group") > 0 Then
levelTemp = getLevel(textline)
If levelTemp < levelTempOld Then
subtractLevel = 0
End If
If InStr(textline, "Pattern") > 0 Or InStr(textline, "Group") > 0 Then
subtractLevel = subtractLevel + 1
k = 1
End If
End If
' Grab material
If InStr(textline, "Materials") > 0 Then
Line Input #FileNum, textline
material = Trim(Replace(textline, "<curr>", ""))
End If
'we need to find out if the line has number as first item, i.e trim away spaces, it prints out previous item here...
If InStr(10, textline, "<HTML>") > 0 Then
'textlineTemp = RemoveHTML(textline)
'textlineTemp = Replace(textlineTemp, "Ã", "Ø")
partNumber = getPartNumber(textline)
commonName = getCommonName(textline)
partType = getType(partNumber)
material = "NA"
' add part to dictionary, this is unique parts
If levelDictionary.exists(partNumber) Then
levelDictionary(partNumber) = levelDictionary(partNumber) + 1
Else
levelDictionary.Add partNumber, 1
End If
' Remove duplicates ......
If partNumberOld = partNumber And levelTempOld = levelTemp Then
duplicate = True
quantity = quantity + 1
Else
quantity = 1
duplicate = False
End If
' get family history
level = levelTemp - subtractLevel
LevelArray(level) = partNumber
'lets present result
If Not duplicate Then
If level > 1 Then
parent = LevelArray(level - 1)
Else
parent = "NA"
End If
If level > 2 Then
grandma = LevelArray(level - 2)
Else
grandma = "NA"
End If
If level > 3 Then
greatgrandma = LevelArray(level - 3)
Else
greatgrandma = "NA"
End If
If level > 4 Then
greatgreatgrandma = LevelArray(level - 4)
Else
greatgreatgrandma = "NA"
End If
If i > 0 Then
Call write2Excel(wsOut, i + 2, partNumberOld, commonNameOld, quantityOld, materialOld, levelOld, partTypeOld, parentOld, grandmaOld, greatgrandmaOld, greatgreatgrandmaOld)
End If
i = i + 1
End If
End If
'we always uses previous values for print out
partNumberOld = partNumber
commonNameOld = commonName
levelOld = level
levelTempOld = levelTemp
partTypeOld = partType
quantityOld = quantity
materialOld = material
textlineOld = textline
parentOld = parent
grandmaOld = grandma
greatgrandmaOld = greatgrandma
greatgreatgrandmaOld = greatgreatgrandma
Loop
Close #FileNum
Debug.Print "How many parts " & i
Call DeList(wsOut)
Call CreateList(wsOut, "FilterOutput")
Call totalBOM(levelDictionary)
End Sub
An alternative OO approach using a class module. Output is to a sheet named "Output2".
Update 1 - Added debugging log, creo.log in same folder as workbook.
Option Explicit
Sub ProcessTextFile()
Const TXTFILE = "treetool_Rextroth.txt" '"treetool20210503.txt"
Const MAX_LEVEL = 10
Dim tree() As clsItem, item As clsItem
Dim ruler() As Integer, level As Integer, rs
Dim FileNum As Integer, textline As String, text As String
Dim start_name As Integer, width_name As Integer, n As Long
Dim t0 As Single: t0 = Timer
ReDim tree(MAX_LEVEL)
ReDim ruler(MAX_LEVEL)
FileNum = FreeFile()
Open ThisWorkbook.Path & "\" & TXTFILE For Input As #FileNum
' use first header line to get common name column position
Line Input #FileNum, textline
start_name = InStr(1, textline, "PTC_COMMON_NAME")
width_name = InStr(1, textline, "PRO_MP_") - start_name
' skip
Line Input #FileNum, textline
' set start level and indent
Set tree(0) = New clsItem
tree(0).level = 0
tree(0).id = "NA"
level = 1
ruler(1) = 1
' open log file
Dim fso, ts
Set fso = CreateObject("Scripting.Filesystemobject")
Set ts = fso.createtextfile("creo.log")
' scan text file
n = 2
Do Until EOF(FileNum)
n = n + 1
Line Input #FileNum, textline
rs = ParseLine(textline, n, ts)
If rs(0) = "ASM" Or rs(0) = "PRT" Then
' determine level from indent
level = GetLevel(ruler, rs(2), level, ts)
' create new item
Set item = New clsItem
With item
.itemtype = rs(0)
.id = rs(1)
.name = Mid(textline, start_name, width_name)
.qu = 1
.level = level
.parent = tree(level - 1).id
.creo = n
End With
' build tree
Set tree(level) = item
tree(level - 1).addItem item
' groups or patterns
ElseIf rs(0) = "GRP" Or rs(0) = "PTN" Then
' increase ruler for current level by 2
ruler(level) = ruler(level) + 2
ts.writeline n & " " & rs(0) & " change ruler(" & level & ")=" & ruler(level)
' materials
ElseIf rs(0) = "MTL" Then
If item.itemtype = "PRT" Then
' get material from next line
n = n + 1
Line Input #FileNum, textline
item.material = Trim(Replace(textline, "<curr>", ""))
End If
End If
Loop
' output tree
Application.ScreenUpdating = False
With Sheets("Output2")
text = .Range("A1")
.Cells.ClearContents
.Cells.Clear
.Range("A1") = text
.Range("B1") = Now
.Range("C1") = TXTFILE
With .Range("A2:H2")
.Value2 = Array("Part No", "Common Name", _
"Qu.", "Material", "Level", "Type", "Parent", "Creo Lines")
.Interior.Color = RGB(255, 200, 0)
.Font.Bold = True
End With
' save objects to sheet
tree(0).SaveToWorksheet .Range("A3")
' prettify
.Range("C:C,E:E").HorizontalAlignment = xlCenter
.Columns("H:H").HorizontalAlignment = xlRight
.Columns("A:H").AutoFit
.ListObjects.add(xlSrcRange, .UsedRange.Offset(1), , xlYes).name = "Table2"
.ListObjects("Table2").TableStyle = "TableStyleLight1"
.Activate
.Range("A1").Select
End With
Application.ScreenUpdating = True
MsgBox Format(n, "#,###") & " lines parsed in " & _
Format(Timer - t0, "0.00") & " seconds"
End Sub
' determine level from indent using ruler
Function GetLevel(ByRef ruler, indent, level, ts) As Integer
Dim n As Integer
n = level ' current level
' is this an increase on previous
If indent > ruler(n) Then
ts.writeline "GetLevel before ruler(" & n & ")=" & ruler(n)
n = n + 1
Else
' find previous level
n = 0
Do
n = n + 1
Loop While indent > ruler(n)
End If
ruler(n) = indent ' update
ts.writeline "Level now " & n & " ruler(" & n & ")=" & indent
GetLevel = n
End Function
' determine linetype, partno, indent
Function ParseLine(s As String, n, ts) As Variant
Dim indent As Integer, partno As String
Dim tmp As String, linetype As String
indent = Len(s) - Len(LTrim(s)) ' no of spaces
If InStr(1, s, "<HTML>") Then
tmp = WorksheetFunction.Trim(s)
partno = Split(tmp, " ")(0)
linetype = Right(partno, 3)
ts.writeline vbCrLf & n & " INDENT=" & indent & " '" & s
ElseIf InStr(1, s, "Materials") Then
linetype = "MTL"
ElseIf InStr(1, s, "Group") Then
linetype = "GRP"
ElseIf InStr(1, s, "Pattern") Then
linetype = "PTN"
End If
ParseLine = Array(linetype, partno, indent)
End Function
class module clsItem
========================
Option Explicit
' this class represent a part or assembly
Public id As String ' partno
Public name As String ' common name
Public itemtype As String ' PRT or ASM
Public parent As String
Public level As Integer
Public qu As Integer
Public material As String
Public creo As String ' source line nos in Creo file
Public items As New Collection
' add items
Public Function addItem(obj As clsItem)
' check if exists, if so increment quantity
Dim item As clsItem, bExists As Boolean
For Each item In items
If item.id = obj.id Then
item.qu = item.qu + obj.qu
item.creo = item.creo & " " & obj.creo
bExists = True
Exit For
End If
Next
' does not exist so add new
If Not bExists Then items.add obj, obj.id
End Function
' save object and all children
Public Sub SaveToWorksheet(rng As Range)
Const SP = 5 ' no of spaces to indent at each level
Dim item As clsItem
If level > 0 Then
rng = Space(level * SP) & id
rng.Offset(0, 1) = name
rng.Offset(0, 2) = qu
rng.Offset(0, 3) = material
rng.Offset(0, 4) = level
rng.Offset(0, 5) = itemtype
rng.Offset(0, 6) = parent
rng.Offset(0, 7) = creo
Set rng = rng.Offset(1)
End If
' recurse
For Each item In Me.items
item.SaveToWorksheet rng
Next
End Sub
This scans the Output sheet and creates a new sheet called "No Duplicates". However, with the bugs in your data I suspect this won't work for more complex cases e.g. where an assembly appears in other assemblies at different levels.
Update 1 - dictionary at each level
Sub RemoveDuplicates()
Const START_ROW = 3 ' skip headers
Const COL_PARTNO = 1 ' A
Const COL_QU = 3 ' C
Const COL_LEVEL = 5 ' E
Const COL_TYPE = 6 ' F
Dim wb As Workbook, ws As Worksheet, wsNew As Worksheet
Dim iLastRow As Long, i As Long, r As Long
Dim PartNo As String, isASM As Boolean
Dim dictLevel As Integer, level As Integer
' dictionary at each level
Dim dictASM(10) As Object, arQu As Variant
Set wb = ThisWorkbook
Set ws = wb.Sheets("Output")
iLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
ReDim arQu(iLastRow)
For i = 0 To 10
Set dictASM(i) = CreateObject("Scripting.Dictionary")
Next
r = START_ROW
dictLevel = 0
Do
PartNo = Trim(ws.Cells(r, COL_PARTNO))
isASM = Trim(ws.Cells(r, COL_TYPE) = "ASM")
arQu(r) = ws.Cells(r, COL_QU)
level = ws.Cells(r, COL_LEVEL)
If isASM Then
' is this a new assembly clear lower level dictionaries
If level < dictLevel Then
For i = dictLevel To UBound(dictASM)
Set dictASM(i) = CreateObject("Scripting.Dictionary")
Next
dictLevel = level
Else
If dictASM(dictLevel).exists(PartNo) Then
' duplicate assembly
' increment first occurence
i = dictASM(dictLevel)(PartNo)
arQu(i) = arQu(i) + arQu(r)
arQu(r) = 0
level = ws.Cells(r, COL_LEVEL)
' delete lower level items
Do While ws.Cells(r + 1, COL_LEVEL) > level
r = r + 1
arQu(r) = 0 ' delete later
Loop
Else
' first occurence
dictASM(dictLevel).add PartNo, r
End If
End If
End If
r = r + 1
Loop While r < iLastRow
' create new sheet without duplicates
Set wsNew = Sheets.add
wsNew.Name = "No Duplicates"
ws.Range("A2:G2").Copy wsNew.Range("A2") ' header
i = START_ROW
For r = START_ROW To iLastRow
If arQu(r) > 0 Then
ws.Cells(r, 1).Resize(1, 8).Copy wsNew.Cells(i, 1)
wsNew.Cells(i, COL_QU) = arQu(r)
i = i + 1
End If
Next
wsNew.Columns("A:G").AutoFit
MsgBox Format(iLastRow - 1, "#,###") & " rows scanned", vbInformation
End Sub
Related
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
I'm trying to populate a form from another table. I have an identifier (formNumber). The loop's purpose is the find all the rows in the table with the same formNumber, then list the details in a form.
Problem encountered is in the fields using startTableRow, startSubdesc1, startSubdesc2, startRemark. I dont know when they are all repeating the same values, that have already been inputted. An item should only appear once.
Dim wsCurrent As Worksheet, _
loTable1 As ListObject, _
lcColumns As ListColumns, _
lrCurrent As ListRow
Set wsCurrent = Worksheets("Expenses")
Set loTable1 = wsCurrent.ListObjects("Expenses")
Set lcColumns = loTable1.ListColumns
'Loop through and find new entries which haven't been form'd yet
For x = 1 To loTable1.ListRows.Count
Set lrCurrent = loTable1.ListRows(x)
If lrCurrent.Range(1, lcColumns("form sent?").Index) = "" And _
lrCurrent.Range(1, lcColumns("form #").Index) <> "" Then
formNumber = lrCurrent.Range(1, lcColumns("form #").Index).Value
'Set first lines on the form
Worksheets("form").Cells(10, 10).Value = formNumber
'Loop through the Expense sheet and as long as the form number doesn't _
'change, write it to the table on the form
startTableRow = 20
startSubdesc1 = 21
startSubdesc2 = 22
startRemark = 54
Do While lrCurrent.Range(1, lcColumns("form #").Index).Value = formNumber
expensesDate = lrCurrent.Range(1, lcColumns("Date").Index).Value
expensesItem = lrCurrent.Range(1, lcColumns("Description").Index).Value
expensesSubdesc1 = lrCurrent.Range(1, lcColumns("Sub-description 1").Index).Value
expensesSubdesc2 = lrCurrent.Range(1, lcColumns("Sub-description 2").Index).Value
expensesRemarks = lrCurrent.Range(1, lcColumns("Remarks").Index).Value
**Worksheets("form").Cells(startTableRow, 5) = expensesItem
Worksheets("form").Cells(startSubdesc1, 5) = expensesSubdesc1
Worksheets("form").Cells(startSubdesc2, 5) = expensesSubdesc2
Worksheets("form").Cells(startRemark, 3) = expensesRemarks
Worksheets("form").Cells(12, 10) = expensesDate**
lrCurrent.Range(1, lcColumns("form sent?").Index).Value = "Yes"
x = x + 1
startTableRow = startTableRow + 3
startSubdesc1 = startSubdesc1 + 3
startSubdesc2 = startSubdesc2 + 3
startRemark = startRemark + 1
Loop
'Need to subtract one from x to loop through the row again
x = x - 1
'Clear data in table on form
For t = 20 To 45
Worksheets("form").Cells(t, 3).Value = ""
Worksheets("form").Cells(t, 5).Value = ""
Next t
'Clear data in REMARK on form
For r = 54 To 57
Worksheets("form").Cells(r, 3).Value = ""
Next r
End If
Next x
End Sub
End Sub
The problem with your code is in the while loop the lrCurrent does not change. after x = x +1 you need to set
lrCurrent = loTable1.ListRows(x) IF x <= loTable1.ListRows.Count
Also then need to protect against running past the end of table by adding another condition
And x <= loTable1.ListRows.Count
to the Do While line at the start.
Here is an example with fewer variables by using .offset
Sub FillForm()
Dim wb As Workbook, ws As Worksheet, wsForm As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Sheets("Expenses")
Set wsForm = wb.Sheets("form")
Dim tbl As ListObject
Set tbl = ws.ListObjects("Expenses")
' create look up for column names
Dim ColNum As New Collection
Dim cell As Range, ix As Integer
For Each cell In tbl.HeaderRowRange
ix = ix + 1
ColNum.add ix, cell.Value
Debug.Print cell.Value
Next
' scan table for not sent items
Dim sFormNo As String, rec As Range
Dim iCount As Integer ' count of lnes with same form no
Dim bSearch As Boolean, iSearch As Integer
Dim iRow As Integer
bSearch = False ' search for matching form no
With tbl
For iRow = 1 To .ListRows.Count
Set rec = .ListRows(iRow).Range
If rec(ColNum("form #")) <> "" _
And rec(ColNum("form sent?")) = "" Then
sFormNo = rec(1)
wsForm.Range("J10") = rec(ColNum("form #"))
wsForm.Range("J12") = rec(ColNum("Date"))
bSearch = True
End If
' search rest of table for more records
If bSearch Then
'Clear data in table on form
'wsForm.Range("C20:C45").ClearContents ' required ?
wsForm.Range("E20:C45").ClearContents
wsForm.Range("C54:C57").ClearContents
iCount = 0
' search from existing row down to end
For iSearch = iRow To .ListRows.Count
Set rec = .ListRows(iSearch).Range
' check match
If rec(ColNum("form #")) = sFormNo _
And rec(ColNum("form sent?")) = "" Then
' fill in form
With wsForm.Range("E20").Offset(3 * iCount, 0)
.Offset(0, 0) = rec(ColNum("Description"))
.Offset(1, 0) = rec(ColNum("Sub-description 1"))
.Offset(2, 0) = rec(ColNum("Sub-Description 2"))
End With
wsForm.Range("C54").Offset(iCount, 0) = rec(ColNum("Remarks"))
' update form sent column
rec(ColNum("form sent?")) = "Yes"
iCount = iCount + 1
Debug.Print "Search for " & sFormNo, rec(ColNum("form #")), iCount, iSearch
End If
Next
wsForm.Activate
wsForm.Range("A20").Select
MsgBox iCount & " lines added", vbInformation, "Completed " & sFormNo
bSearch = False
End If
Next
End With
MsgBox "Ended", vbInformation
End Sub
I have a file path in Column A and want to display the count of how many files are between a date range, and if there are any files I want to be able to have a comment on the cell showing the file names and dates.
I have a code that I've gotten help on, but when the code runs it counts all the files in the folder and the comment only appears on the last number in the column.
Sub CreateMouseoverList(Optional FileFilter As String, Optional LowDate As Date, Optional HighDate As Date)
Dim Cell As Range
Dim Ext As Variant
Dim File As Object
Dim FileCnt As Long
Dim Files As Object
Dim Folder As Variant
Dim Item As Variant
Dim List() As Variant
Dim MaxLen As Long
Dim ModDate As Date
Dim m As Long
Dim n As Long
Dim Note As Comment
Dim Text As String
If IsMissing(FileFilter) Then FileFilter = "*.*"
' // Is there is no LowDate then use 1.
If LowDate = 0 Then LowDate = 2
' // If there is no HighDate then use today's date.
If HighDate = 0 Then HighDate = Now()
With CreateObject("Shell.Application")
For Each Cell In Range("A1", Cells(Rows.count, "A").End(xlUp))
FileCnt = 0
ReDim List(1 To 1)
Set Note = Cell.Offset(0, 1).Comment
If Note Is Nothing Then Set Note = Cell.Offset(0, 1).AddComment
Note.Shape.TextFrame.Characters(1, Len(Note.Text)).Delete
Note.Shape.TextFrame.Characters.Font.FontStyle = "regular"
Set Folder = .Namespace(Cell.Value)
If Not Folder Is Nothing Then
Set Files = Folder.Items
For Each Ext In Split(FileFilter, ";")
Files.Filter 64, Ext
Text = vbLf & " " & Ext & " Files | " & vbLf
List(UBound(List)) = Text
n = UBound(List) + 1
ReDim Preserve List(1 To n)
Text = String(Len(Text), "-") & " | " & vbLf
List(UBound(List)) = Text
n = UBound(List) + 1
ReDim Preserve List(1 To n)
Note.Shape.TextFrame.Characters.Font.Name = "Courier New"
Note.Shape.TextFrame.AutoSize = True
For Each File In Files
ModDate = File.ModifyDate
If ModDate >= LowDate And HighDate <= HighDate Then
FileCnt = FileCnt + 1
Text = File.Name & " | " & ModDate & vbLf
List(n) = Text
n = UBound(List) + 1
ReDim Preserve List(1 To n)
If Len(Text) > MaxLen Then MaxLen = Len(Text)
End If
Next File
Next Ext
Cell.Offset(0, 1).Value = FileCnt
Else
Cell.Offset(0, 1).Value = "Folder not found."
End If
Next Cell
End With
For Each Item In List
m = Len(Item)
n = Note.Shape.TextFrame.Characters.count + 1
Item = Split(Item, "|")
If UBound(Item) > -1 Then
Text = Item(0) & String(MaxLen - m, 32) & Item(1)
Note.Shape.TextFrame.Characters(n, Len(Text)).Insert Text
End If
Next Item
End Sub
Sub TestIt()
Call CreateMouseoverList("*.txt;*.xls", "4/1/2019","6/10/2019")
End Sub
I would like to be able to count all the files that are between a date range and display what the files are as well as the count.
I have the following Excel sheet which has random number combinations build using numbers from 2 to 50 in set of 3, 2 and 1 in Column A.
I am trying to build whole possible combinations between Column A elements such that the obtained combination doesn't have any repeating numbers in them and contains all the number from 2 to 50.
My current code starts from A2 and builds only a single combination set. It doesn't evaluate other possible combinations with starting element as in A2, it then goes to A3 and then builds only one combination set using A3. This step continues for A4,A5...
This is my current code.
Private Sub RP()
Dim lRowCount As Long
Dim temp As String, s As String
Dim arrLength As Long
Dim hasElement As Boolean
Dim plans() As String, currentPlan() As String
Dim locationCount As Long
Dim currentRoutes As String
Dim line As Long
Worksheets("Sheet1").Activate
Application.ActiveSheet.UsedRange
lRowCount = ActiveSheet.UsedRange.Rows.Count
locationCount = -1
line = 2
Debug.Print ("*********")
For K = 2 To lRowCount - 1
currentRoutes = ""
For i = K To lRowCount
s = ActiveSheet.Cells(i, 1)
Do
temp = s
s = Replace(s, " ", "")
Loop Until temp = s
currentPlan = Split(Trim(s), ",")
arrLength = UBound(currentPlan) - LBound(currentPlan) + 1
hasElement = False
If Len(Join(plans)) > 0 Then
For j = 0 To arrLength - 1
pos = Application.Match(currentPlan(j), plans, False)
If Not IsError(pos) Then
hasElement = True
Exit For
End If
Next j
End If
If Not hasElement Then
currentRoutes = currentRoutes & (Join(currentPlan, ",")) & " "
If Len(Join(plans)) > 0 Then
plans = Split(Join(plans, ",") & "," & Join(currentPlan, ","), ",")
Else
plans = currentPlan
End If
End If
Next i
If locationCount < 0 Then
locationCount = UBound(plans) - LBound(plans) + 1
End If
If (UBound(plans) - LBound(plans) + 1) < locationCount Then
Debug.Print ("Invalid selection")
Else
Debug.Print (Trim(currentRoutes))
Worksheets("Sheet1").Cells(line, 11) = currentRoutes
line = line + 1
End If
Erase plans
Debug.Print ("*********")
Next K
End Sub
In my organization we have one old project/application which was build on Visual Basic 6.0
In that application we have export to Excel "button" where data gets populated into different tabs in spreadsheet with click. It was working very well with Excel 2010 and later until we moved to EXCEL 2013.
Issue: We need data to get exported into 2 tabs in excel 2013 whereas its coming in 1 tab only. I tried using package and deployment wizard and all possible help available. So far no luck. Please let me know if you have any questions or if I am not enough clear. Please find below my code.
Dim uprev As Integer
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlsheet2 As Excel.Worksheet
Dim ExcelWasNotRunning As Boolean ' Flag for final release.
Dim n As Integer
Dim n1 As Integer
Dim n2 As Integer
Dim i As Integer
Dim lastrevdate As String
Dim lastrevrow As Integer
Dim lastrow As Integer
Dim previouspcno As Integer
Dim xlcol As String
Dim j As Integer
Dim k As Integer
Dim dc As Adodc
Dim mrc As Recordset
Dim qpa As New QPArray
Dim Found As Long
Dim StartInd As Long
Dim bFound As Boolean
Dim crlf As String
On Error GoTo errorhandler1
crlf = Chr(13) & Chr(10)
ReDim qs(10) As String
ReDim q(10) As Integer
ReDim hdr(15) As Integer
ReDim rev(10, 0) As String
ReDim part(0) As String
ReDim sl(nof) As String
ReDim cmpsql2(0) As String
ReDim deletedfromsql(3, 0) As String
Dim doThis As Integer
Dim iReturn As Integer
Dim revlev As String
Dim Date_Engr As String
Dim Date_Checker As String
'On Error Resume Next ' Defer error trapping.
'Removed, not checking to see if excel is open properly
'Bert - 6/5/07
'Set xlApp = GetObject(, "Excel.Application")
'If Err.Number <> 0 Then
' ExcelWasNotRunning = True
'Else
' MsgBox ("Please Close Excel before continuing")
' Exit Sub
'End If
Err.Clear ' Clear Err object in case error occurred.
iReturn = MsgBox("Please Close ALL Excel applications before continuing", vbOKOnly, "WARNING")
ExcelWasNotRunning = True
'fixwidth
Screen.MousePointer = vbHourglass
'DetectExcel
Set xlApp = Excel.Application
'path(8) = "C:\SwitchGear\Files1\eng_prod\Jobs\cs01157\medt\"
If Dir(Defaults.medt & "\" & cs & sos & "mbom.xls", vbNormal) <> "" Then
mbomflag = 1
FileCopy Defaults.medt & "\" & cs & sos & "mbom.xls", Defaults.medt & "\" & cs & sos & "mbom.bak"
Set xlBook = GetObject(Defaults.medt & "\" & cs & sos & "mbom.xls")
Set xlSheet = xlBook.Worksheets(1)
Set xlsheet2 = xlBook.Worksheets(2)
Do
qs(1) = "1. Do not list changes on rev sheet" & crlf
qs(1) = qs(1) & "2. list changes on rev sheet but do not increase rev level" & crlf
qs(1) = qs(1) & "3. list changes on rev sheet and increase rev level"
qs(0) = InputBox(qs(1))
If qs(0) = "" Then Exit Sub
Loop Until qs(0) > "0" And qs(0) < "4"
If qs(0) = "3" Then ' up the revision
uprev = 2
revlev = xlsheet2.Cells(5, 3) + 1
Date_Engr = Date
Date_Checker = Date
Else
uprev = 1
revlev = xlsheet2.Cells(5, 3)
Date_Engr = xlSheet.Cells(16, 2) ' get the old rev number
Date_Checker = xlSheet.Cells(16, 3)
End If
lastrow = xlSheet.Cells.Range("E20").End(xlDown).Row
ReDim cmpxl2(0) As String
ReDim cmpxl3(0) As String
ReDim cmpxl4(0) As String
n = 0
For i = 20 To lastrow
If xlSheet.Cells(i, 2) <> "" Then
n = n + 1
ReDim Preserve cmpxl2(n) As String
ReDim Preserve cmpxl3(n) As String
ReDim Preserve cmpxl4(n) As String
cmpxl2(n) = xlSheet.Cells(i, 2) & " " & Format(i)
cmpxl3(n) = xlSheet.Cells(i, 3)
cmpxl4(n) = xlSheet.Cells(i, 4)
End If
Next i
n1records = Adodc1.Recordset.RecordCount
'If n > n1records Then 'it's been deleted from sql so find the part and add to xl revision sheet
n1 = 0
ReDim cmpsql2(n1records) As String
With Adodc1.Recordset
For i = 1 To n1records
If i = 1 Then
Adodc1.Recordset.MoveFirst
Else
Adodc1.Recordset.MoveNext
End If
cmpsql2(i) = !pcno
Next i
End With
For i = 1 To n
bFound = qpa.Find(cmpsql2(), Left$(cmpxl2(i), 4), Found, , 1)
If bFound = False Then
q(1) = Val(Mid$(cmpxl2(i), 6))
n1 = n1 + 1
ReDim Preserve deletedfromsql(3, n1)
deletedfromsql(1, n1) = xlSheet.Cells(q(1), 2)
deletedfromsql(2, n1) = xlSheet.Cells(q(1), 3)
deletedfromsql(3, n1) = xlSheet.Cells(q(1), 4)
End If
Next i
'End If
n = 0
Do
n = n + 1
If xlsheet2.Cells(n + 13, 1) > " " Then
ReDim Preserve rev(10, n)
ReDim Preserve part(n)
'part(n) = xlSheet.Cells(n + 13, 3) & "*" & xlSheet.Cells(n + 13, 1)
If xlsheet2.Cells(n + 13, > CDate(lastrevdate) Then
lastrevdate = xlsheet2.Cells(n + 13, 8-)
End If
For i = 1 To 10
rev(i, n) = xlsheet2.Cells(n + 13, i)
Next i
Else
Exit Do
End If
Loop
If engr = "" Then
engr = xlSheet.Cells(14, 2)
chcked = xlSheet.Cells(14, 3)
End If
Else
mbomflag = 0
revlev = 0
If engr = "" Then
engr = UCase$(InputBox("Enter Mechanical drafter's Initials:", "Enter Initials"))
'If engr = "" Then Exit Sub
chcked = UCase$(InputBox("Enter Checker's Initials:", "Enter Initials"))
'If chcked = "" Then Exit Sub
End If
End If
'Set xlBook = GetObject(path(2) & "vb\sql\ebomtemplate.xls")
Set xlBook = GetObject(Defaults.ApplicationPath & "\mbomTemplate.xls")
Set xlSheet = xlBook.Worksheets(1)
Set xlsheet2 = xlBook.Worksheets(2)
If revlev = 0 Then
xlsheet2.Cells(14, 8= Date
End If
'xlSheet.PageSetup.Zoom = 50
If UBound(rev, 2) > 0 Then
lastrevrow = UBound(rev, 2) + 13
For i = 14 To UBound(rev, 2) + 13
For j = 1 To 10
xlsheet2.Cells(i, j) = rev(j, i - 13)
Next j
Next i
Else
lastrevrow = 13
End If
'If uprev = 1 Then
' xlBook.Application.Visible = True
' xlBook.Parent.Windows(2).Visible = True
' xlBook.Parent.Windows(2).Activate
' xlSheet.Activate
'bFound = bringwindowtotop(hwnd)
'xlBook.Sheets(1).Select
'ActiveSheet.Visible = True
'xlBook.Application.DoubleClick
'Else
xlBook.Application.Visible = True
xlBook.Parent.Windows(1).Visible = True
xlBook.Parent.Windows(1).Activate
xlSheet.Activate
'DetectExcel
'bFound = bringwindowtotop(hwnd)
'End If
'DetectVB
'Found = apiShowWindow(hwnd, SW_SHOWMINIMIZED)
'DetectExcel
'Found = apiShowWindow(hwnd, SW_SHOWMAXIMIZED)
Me.Visible = False
Screen.MousePointer = vbDefault
'If uprev = 1 Then
' xlBook.NewWindow.Activate
' With xlBook.NewWindow
' .ActiveSheet = 2
' .Zoom = 50
' End With
'End If
'xlBook.Application.Visible = True
'xlBook.Parent.Windows(1).Visible = True
'xlSheet.Activate
'qs(1) = "03040609121314151617181920212223242526272829303132333435"
cs = UCase$(cs)
sos = UCase$(sos)
xlSheet.Cells(10, 2) = cs & Left$(sos, 5)
If Val(framestr(0, 0, 15)) < 8 Then qs(1) = "2" Else qs(1) = "4"
xlSheet.Cells(10, 3) = "-" & Mid$(sos, 6, 1) & Right$(sos, 1) & "B" & qs(1) & "004"
xlSheet.Cells(12, 2) = Right$(sos, 3)
xlSheet.Cells(10, 6) = framestr(0, 0, 3)
'xlSheet.Cells(12, 3) = "0"
'xlSheet.Cells(16, 2) = Date
'xlSheet.Cells(16, 3) = Date
xlSheet.Cells(10, 4) = framestr(0, 0, 658) 'sold to
xlSheet.Cells(11, 4) = framestr(0, 0, 657)
xlSheet.Cells(12, 4) = framestr(0, 0, 656)
xlSheet.Cells(14, 2) = engr
xlSheet.Cells(14, 3) = chcked
xlSheet.Cells(14, 4) = framestr(0, 0, 655) 'for
xlSheet.Cells(14, 6) = framestr(0, 0, 661) 'purchase order
xlSheet.Cells(15, 4) = framestr(0, 0, 654)
xlSheet.Cells(16, 4) = framestr(0, 0, 653)
xlcol = "L M N O P Q R S T U V W X Y Z AAABACADAEAFAGAHAIAJ"
qs(1) = "L12:" & Trim$(Mid$(xlcol, (nof + 1) * 2 - 1, 2)) & "16"
xlSheet.Cells.Range(qs(1)).Value = " "
For i = 1 To nof
xlSheet.Cells(19, i + 11) = i
Next i
For i = 1 To nof + 1
qs(1) = Trim$(Mid$(xlcol, i * 2 - 1, 2)) & "12:" & Trim$(Mid$(xlcol, i * 2 - 1, 2)) & "16"
With xlSheet.Cells.Range(qs(1)).Borders(xlLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
Next i
qs(1) = Chr(76) & "12:" & Trim$(Mid$(xlcol, nof * 2 - 1, 2)) & "12"
With xlSheet.Cells.Range(qs(1)).Borders(xlTop)
'.LineStyle = xlContinuous
.Weight = xlMedium
End With
qs(1) = Chr(76) & "16:" & Trim$(Mid$(xlcol, nof * 2 - 1, 2)) & "16"
With xlSheet.Cells.Range(qs(1)).Borders(xlBottom)
'.LineStyle = xlContinuous
.Weight
I am aware VB 6 is outdated and not sure why they don't move to VB.NET. I would really appreciate if anyone can help. Thanks in advance :)
Your problem is nothing to do with VB6 being outdated. The problem is that this code is unrunnable. I can only make a guess that this is some hacked version based on the real running code. I will make some guesses based on approximately what this code should really look like. However, it would be a good idea to provide the actual code.
By "tabs", I take it you mean "worksheets". I am guessing that they are called "Sheet1" and "Sheet2". So basically, only "Sheet1" is actually getting re-populated. "Sheet2" remains as it previously looked.
I would suggest that you put a breakpoint on the line:
Set xlsheet2 = xlBook.Worksheets(2)
See whether xlsheet2.Cells(14,8) evaluates to the date you expect to see on that worksheet.
After stepping through this line, ensure that xlsheet2 actually points to the worksheet you expect it to. I would also put breakpoints on every line which reads or writes xlsheet2.Cells(x,y) evaluate it, and look at sheet2, ensuring that the value read or written back is correct.