I have the below code that works fine, however i am trying to amend th code to no avail so that it saves the files with the leading Zeros.
the number element are store numbers and it ranges from 1 - 168
ideally if possible can you advise how do i change the code so it saves the output files like the below example if a store number is 2 digits and the 3 digits etc.
0001
0010
0120
Sub GenerateOutput()
Dim i As Long
Dim iGradeRow As Long
Dim iGradeCol As Long
Dim iPosSeqRow As Long
Dim s(1 To 7) As String
Dim aGradeData() As Variant
Dim aPosSeq() As Variant
Dim aOutput(1 To 500000, 1 To 12) As Variant
Dim iNextOutputRow As Long
Dim ExportWorkbook As Workbook
Dim Site As String
Dim Department As String
Dim Category As String
Dim ArticleGrade As String
Dim dp As String
Dim ct As String
Dim posQty As Long
Dim y As Long
Dim lrStores As Long
Dim recordId As Long
Dim selId As Long
'------------------------
Application.ScreenUpdating = False
' Get arrays of data to loop round
With ws_Grades
aGradeData = .Cells(1, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft).Column).Value2
End With
With ws_PosSeq
aPosSeq = .Cells(1, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row, 20).Value2
End With
s(1) = "( "
's(2) = iGradeRow - 3
s(3) = " / "
's(4) = UBound(aGradeData, 1) - 3
s(5) = " ) "
's(6) = "Collecting data for: "
's(7) = aGradeData(iGradeRow, 2)
'Application.StatusBar = Join(s)
'DoEvents: DoEvents
'check the departments and categories
For iGradeRow = 4 To UBound(aGradeData, 1)
's(1) = "( "
s(2) = iGradeRow - 3
's(3) = " / "
s(4) = UBound(aGradeData, 1) - 3
's(5) = " ) "
s(6) = "Collecting data for: "
s(7) = aGradeData(iGradeRow, 2)
Application.StatusBar = Join(s)
DoEvents: DoEvents
Application.ScreenUpdating = False
Erase aOutput
iNextOutputRow = 1
For iGradeCol = 3 To UBound(aGradeData, 2)
Site = aGradeData(iGradeRow, 1)
Department = aGradeData(1, iGradeCol)
Category = aGradeData(3, iGradeCol)
ArticleGrade = aGradeData(iGradeRow, iGradeCol)
If iNextOutputRow = 1 Then
recordId = 1
selId = 1
Else
recordId = aOutput(iNextOutputRow - 1, 1) + 1
selId = aOutput(iNextOutputRow - 1, 2) + 1
End If
'check the departments & categories in the opened workbook
For iPosSeqRow = 3 To UBound(aPosSeq, 1)
'if there is nil in the first column, go to the next loop
If aPosSeq(iPosSeqRow, 1) = 0 Then GoTo NextDepartment
'if the department name and category name matches:
If (Trim(LCase(aPosSeq(iPosSeqRow, 2))) = Trim(LCase(Department))) And (Trim(LCase(aPosSeq(iPosSeqRow, 3))) = Trim(LCase(Category))) Then
dp = aPosSeq(iPosSeqRow, 2)
ct = aPosSeq(iPosSeqRow, 3)
'check wether the grades match:
If Not Trim(LCase(aPosSeq(iPosSeqRow, 6))) = Trim(LCase(ArticleGrade)) Then GoTo NextValue
'check pos qty:
posQty = aPosSeq(iPosSeqRow, 12)
'check department: same like the last one?:
If Not iNextOutputRow = 1 Then
If Trim(LCase(aOutput(iNextOutputRow - 2, 7))) = Trim(LCase(Site)) And _
Trim(LCase(aOutput(iNextOutputRow - 2, 5))) = Trim(LCase(dp)) And _
Trim(LCase(aOutput(iNextOutputRow - 2, 6))) = Trim(LCase(ct)) Then GoTo Level3
If Trim(LCase(aOutput(iNextOutputRow - 2, 7))) = Trim(LCase(Site)) And _
Trim(LCase(aOutput(iNextOutputRow - 2, 5))) = Trim(LCase(dp)) And _
Trim(LCase(aOutput(iNextOutputRow - 2, 6))) <> Trim(LCase(ct)) Then GoTo Level2
If Trim(LCase(aOutput(iNextOutputRow - 2, 7))) = Trim(LCase(Site)) And _
Trim(LCase(aOutput(iNextOutputRow - 2, 5))) <> Trim(LCase(dp)) And _
Trim(LCase(aOutput(iNextOutputRow - 2, 6))) <> Trim(LCase(ct)) Then GoTo Level2
End If
Level1:
' Record Id
aOutput(iNextOutputRow, 1) = iNextOutputRow
' SEL_ID
aOutput(iNextOutputRow, 2) = selId
' Front + Back
aOutput(iNextOutputRow, 3) = "F"
' Template_Type
aOutput(iNextOutputRow, 4) = "Store"
' Store No
aOutput(iNextOutputRow, 7) = Site
iNextOutputRow = iNextOutputRow + 1
' Record Id
aOutput(iNextOutputRow, 1) = iNextOutputRow
' SEL_ID
aOutput(iNextOutputRow, 2) = selId
' Back
aOutput(iNextOutputRow, 3) = "B"
' Template_Type
aOutput(iNextOutputRow, 4) = "Store"
' Store No
aOutput(iNextOutputRow, 7) = Site
iNextOutputRow = iNextOutputRow + 1
Level2:
'Record Id
aOutput(iNextOutputRow, 1) = iNextOutputRow
'SEL_ID
aOutput(iNextOutputRow, 2) = aOutput(iNextOutputRow - 1, 2) + 1
'Front_Back
aOutput(iNextOutputRow, 3) = "F"
'Template_Type
aOutput(iNextOutputRow, 4) = "Category"
'Department
aOutput(iNextOutputRow, 5) = dp
'Category
aOutput(iNextOutputRow, 6) = ct
'Store No
aOutput(iNextOutputRow, 7) = Site
iNextOutputRow = iNextOutputRow + 1
'Record Id
aOutput(iNextOutputRow, 1) = iNextOutputRow
'SEL_ID
aOutput(iNextOutputRow, 2) = aOutput(iNextOutputRow - 1, 2)
'Front_Back
aOutput(iNextOutputRow, 3) = "B"
'Template_Type
aOutput(iNextOutputRow, 4) = "Category"
'Department
aOutput(iNextOutputRow, 5) = dp
'Category
aOutput(iNextOutputRow, 6) = ct
'Store No
aOutput(iNextOutputRow, 7) = Site
iNextOutputRow = iNextOutputRow + 1
Level3:
For i = 1 To posQty
'Record Id
aOutput(iNextOutputRow, 1) = iNextOutputRow
'SEL_ID
If i = 1 Then
aOutput(iNextOutputRow, 2) = aOutput(iNextOutputRow - 1, 2) + 1
Else
aOutput(iNextOutputRow, 2) = aOutput(iNextOutputRow - 1, 2)
End If
'Front_Back
aOutput(iNextOutputRow, 3) = "F"
'Template_Type
aOutput(iNextOutputRow, 4) = "SEL"
'Department
aOutput(iNextOutputRow, 5) = dp
'Category
aOutput(iNextOutputRow, 6) = ct
'Store No
aOutput(iNextOutputRow, 7) = Site
'Barcode No
aOutput(iNextOutputRow, 8) = aPosSeq(iPosSeqRow, 8)
'Article Description
aOutput(iNextOutputRow, 9) = aPosSeq(iPosSeqRow, 7)
'WasWas
aOutput(iNextOutputRow, 10) = aPosSeq(iPosSeqRow, 13)
'Was
aOutput(iNextOutputRow, 11) = aPosSeq(iPosSeqRow, 14)
'Now
aOutput(iNextOutputRow, 12) = aPosSeq(iPosSeqRow, 16)
iNextOutputRow = iNextOutputRow + 1
'Record Id
aOutput(iNextOutputRow, 1) = iNextOutputRow
'SEL_ID
aOutput(iNextOutputRow, 2) = aOutput(iNextOutputRow - 1, 2)
'Front_Back
aOutput(iNextOutputRow, 3) = "B"
'Template_Type
aOutput(iNextOutputRow, 4) = "SEL"
'Department
aOutput(iNextOutputRow, 5) = dp
'Category
aOutput(iNextOutputRow, 6) = ct
'Store No
aOutput(iNextOutputRow, 7) = Site
'Barcode No
aOutput(iNextOutputRow, 8) = aPosSeq(iPosSeqRow, 8)
'Article Description
aOutput(iNextOutputRow, 9) = aPosSeq(iPosSeqRow, 7)
iNextOutputRow = iNextOutputRow + 1
Next i
End If
NextValue:
Next iPosSeqRow
NextDepartment:
Next iGradeCol
's(1) = "( "
's(2) = iGradeRow - 3
's(3) = " / "
's(4) = UBound(aGradeData, 1) - 3
's(5) = " ) "
s(6) = "Generating export for: "
's(7) = aGradeData(iGradeRow, 2)
Application.StatusBar = Join(s)
DoEvents: DoEvents
Application.ScreenUpdating = False
' Clean output data
For i = 1 To iNextOutputRow
aOutput(i, 1) = Format(aOutput(i, 1), "0000000")
aOutput(i, 2) = Format(aOutput(i, 2), "0000000")
aOutput(i, 7) = Format(aOutput(i, 7), "0000")
aOutput(i, 8) = "'" & aOutput(i, 8)
Next i
ws_Output.Cells(2, 1).Resize(ws_Output.UsedRange.Rows.Count, 12).ClearContents
ws_Output.Cells(2, 1).Resize(iNextOutputRow, 12).Value2 = aOutput
Application.ScreenUpdating = False
If ExportWorkbook Is Nothing Then
Set ExportWorkbook = Workbooks.Add
ThisWorkbook.Activate
End If
Application.ScreenUpdating = False
ExportWorkbook.Worksheets(1).Cells.Clear
ws_Output.UsedRange.Copy
ExportWorkbook.Worksheets(1).Cells(1, 1).PasteSpecial xlPasteAll
Application.CutCopyMode = False
ExportWorkbook.SaveCopyAs ThisWorkbook.Path & Application.PathSeparator & aGradeData(iGradeRow, 1) & "_" & aGradeData(iGradeRow, 2) & "_" & Format(Now(), "ddmmyyyy_hhmm") & ".xlsx"
ws_Output.Cells(2, 1).Resize(ws_Output.UsedRange.Rows.Count, 12).ClearContents
Next iGradeRow
EndingSub:
ExportWorkbook.Close False
Set ExportWorkbook = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox "Generated Workbooks.", vbInformation
End Sub
Appent 3 zeros to the left of the number element and use
Right() to get exact 4 digits
You should not post your entire code, but rather the relevant parts of it only, so that noone needs to search through the code, to find the importand parts.
To your question:
To fill your numbers with leading zeros you could do something like the following:
Sub test()
Dim numLen As Integer
Dim i As Integer
Dim test As String
numLen = 4 '4 is the lengh like in your example `0001`
'test = "1"
'test = "11" 'Some numbers to test the code
test = "111"
'Depending on the Lenght of the String, additional leading zeros will be added
For i = Len(test) To numLen - 1
test = "0" & test
Next
MsgBox (test)
End Sub
Related
I have a VBA code to compare data from 2 sheets, so i have created the vba code but it is slow so i though to store sheet data in temp memory some how and instead switching sheets between it should use from temp memory.
My code-
For i = 2 To F1_iRowMax
Dim RV As Long
RV = 0
' On Error Resume Next
'RV = Application.WorksheetFunction.Match(F1_Workbook.Sheets(ShName).Cells(i, 16384).Value, F2_Workbook.Sheets(ShName2).Range("XFD1:XFD1048576"), 0)
RV = Application.WorksheetFunction.Match(F1_Workbook.Sheets(ShName).Cells(i, 16384).Value, KeyRange, 0)
On Error Resume Next
If Not IsError(RV) Then
Else
End If
Counter = 0
Counter = Counter + 1
pctdone = Counter / F1_iRowMax
With ufProgress
.LabelCaption.Caption = "Comparing Part-1 " & i & " of " & F1_iRowMax
.LabelProgress.Width = pctdone * (.FrameProgress.Width - 10)
End With
If RV <> 0 Then
''''F1 VS F2
' ColumnNumber = iCol_Max
'ColumnLetter = Split(Cells(1, ColumnNumber).Address, "$")(1)
For iCol = 1 To iCol_Max
F1_Data = F1_Workbook.Sheets(ShName).Cells(i, iCol)
F2_Data = F2_Workbook.Sheets(ShName2).Cells(RV, iCol)
'If i = 39100 Then Stop '''for debug
If F1_Data <> F2_Data Then
'
sIdx = sIdx + 1
' ThisWorkbook.Sheets("Summary").Cells(sIdx, 1) = F1_Workbook.Sheets(ShName).Cells(iRow, iCol).Address
ThisWorkbook.Sheets("Summary").Cells(sIdx, 3) = F1_Workbook.Sheets(ShName).Cells(Header, iCol).Value
ThisWorkbook.Sheets("Summary").Cells(sIdx, 1) = F1_Workbook.Sheets(ShName).Cells(i, 16384).Value
ThisWorkbook.Sheets("Summary").Cells(sIdx, 2) = F1_Workbook.Sheets(ShName).Cells(i, 1).Value
ThisWorkbook.Sheets("Summary").Cells(sIdx, 4) = F1_Data
ThisWorkbook.Sheets("Summary").Cells(sIdx, 5) = F2_Data
ThisWorkbook.Sheets("Summary").Cells(sIdx, 6) = "Data Mismatch"
'ThisWorkbook.Sheets("Summary").Cells(sIdx, 3).Select
End If
Next iCol
Else
sIdx = sIdx + 1
ThisWorkbook.Sheets("Summary").Cells(sIdx, 1) = F1_Workbook.Sheets(ShName).Cells(i, 16384).Value
ThisWorkbook.Sheets("Summary").Cells(sIdx, 2) = F1_Workbook.Sheets(ShName).Cells(i, 1).Value
ThisWorkbook.Sheets("Summary").Cells(sIdx, 4) = "Record Exist"
ThisWorkbook.Sheets("Summary").Cells(sIdx, 6) = "No Record Found"
'ThisWorkbook.Sheets("Summary").Cells(sIdx, 3).Select
End If
Next i
I want to compare 40k rows between 2 sheets.
Sub FallOrSpringsemester()
Dim enrollPeriod As String
Dim i As Integer
Dim LastRow As Integer
Dim w As Worksheet
Dim text As String
Set w = Sheets.Add(after:=Sheets(Sheets.Count))
w.Name = "oldest Students"
Worksheets("oldest Students").Cells(1, 1) = "Student_ID"
Worksheets("oldest Students").Cells(1, 2) = "Enroll_Date"
Worksheets("oldest Students").Cells(1, 3) = "Program_Type_Name"
Worksheets("oldest Students").Cells(1, 4) = "Enrollment_Period"
LastRow = Worksheets("Base").Range("D" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
Worksheets("oldest students").Cells(i, 1) = Worksheets("Base").Cells(i, 12)
Worksheets("oldest students").Cells(i, 2) = Worksheets("Base").Cells(i, 4)
Worksheets("oldest students").Cells(i, 3) = Worksheets("Base").Cells(i, 11)
Above this coding I ofc have my dimed variables and also coding for creating a new sheet.
I have trouble with this part as it will no do the calculations and tells me there is an error
"13": type miss match
If enrollPeriod Mod 2 = 0 Then
Worksheets("oldest Students").Cells(i, 2) = "Spring"
enrollPeriod = enrollPeriod + 1
Worksheets("oldest Students").Cells(i, 1) = 2018 - ((138 - enrollPeriod) / 2)
Else
Worksheets("oldest Students").Cells(i, 2) = "Fall"
Worksheets("oldest Students").Cells(i, 1) = 2018 - ((138-enrollPeriod) / 2)
End if
Next
End Sub
I think enrollPperiod should be an integer... that should fix it
I have the following code. The Loop seems to function well but the ColNum and RowNum lines are only creating 0's the data up to this point is filled out so a blank isn't causing the issue
If Sheets("Control").Range("B6") = "#.#" Then
For i = 1 To ColACount - 2
If FullData(i, 3) <= Sheets("Control").Range("B5") _
And FullData(i, 3) >= Sheets("Control").Range("B4") Then
ColNum = WorksheetFunction.Match(FullData(i, 1), Application.Index(RetGross, 1), 0)
RowNum = WorksheetFunction.Match(FullData(i, 3), Application.Index(RetGross, , 1), 0)
If RetGross(RowNum, ColNum) = "" Then 'Prevents overwriting
RetGross(RowNum, ColNum) = FullData(i, 4)
End If
End If
Next i
End If
I have used Application.Worksheetfunction on the Index and then it really crashes.
Edit: All Code
Sub TransferData()
'Declarations
Dim ReturnWB As String 'File name from Investment metrics
Dim ReturnWBtab1 As String
Dim ReturnWBtab2 As String
Dim ReturnWBtab3 As String
Dim ColACount As Integer 'Total data in column A of Return Puller
Dim FullDataP As Variant ' Pulling data
Dim FullData As Variant ' Building Matrix
Dim Names As Variant
Dim Unique As Integer 'Total Number of unique names
Dim Months As Integer 'Months Specified
Dim StartYear As Integer
Dim EndYear As Integer
Dim StartMonth As Integer
Dim EndMonth As Integer
Dim RetGross As Variant 'Tab data
Dim RetNet As Variant 'Tab data
Dim MValues As Variant 'Tab data
Dim Corner As String 'set the corner value for pasting the array
Dim ColNum As Integer 'Dynamic variable to update matrix
Dim RowNum As Integer 'Dynamic variable to update matrix
Dim First As Integer 'First row for shading - Dynamic and changing
Dim Inceptions As Variant 'Inception Dates
Dim BotRow As Integer 'Testing for Gaps
Dim TopRow As Integer 'Testing for Gaps
'Call Clearing
Workbooks("Return Formatter - Investment Metrics.xlsm").Activate
'Setting Names
ReturnWB = Sheets("Control").Range("B3") & ".xls" 'Excel Name
ReturnWBtab1 = "Pre Fee Returns" 'Tab Name
ReturnWBtab2 = "After Fee Returns" 'Tab Name
ReturnWBtab3 = "Total Fund Market Value" 'Tab Name
'Error Control
On Error GoTo Err1
'Prepping the Dates and Name
StartYear = Year(Sheets("Control").Range("B4"))
EndYear = Year(Sheets("Control").Range("B5"))
StartMonth = Month(Sheets("Control").Range("B4"))
EndMonth = Month(Sheets("Control").Range("B5"))
Months = (EndYear - StartYear + 1) * 12 - (StartMonth - 1) - (12 - EndMonth)
'Find all the unique names/managers and list them
ColACount = WorksheetFunction.CountA(Workbooks(ReturnWB).Sheets(ReturnWBtab1).Range("B:B"))
'Building a Matrix
FullDataP = Workbooks(ReturnWB).Sheets(ReturnWBtab1).Range("B2:E" & ColACount)
FullData = FullDataP
ReDim Preserve FullData(1 To (ColACount - 1), 1 To 5)
'Adding Start Date
FullData(1, 5) = FullData(1, 3)
For i = 2 To (ColACount - 1)
If FullData(i, 1) = FullData(i - 1, 1) Then
FullData(i, 5) = FullData(i - 1, 5)
Else
FullData(i, 5) = FullData(i, 3)
End If
Next i
ReDim Names(1 To 3, 1 To ColACount - 1) 'Setting max size
Names(1, 1) = FullData(1, 1) ' loading first value
Names(2, 1) = FullData(1, 5) ' loading first value
Names(3, 1) = 1 'Tracking the count
x = 1
For i = 1 To (ColACount - 2)
If Names(1, x) <> FullData(i + 1, 1) Then
Names(1, x + 1) = FullData(i + 1, 1)
Names(2, x + 1) = FullData(i + 1, 5)
Names(3, x + 1) = 1 'Tracking the count
x = x + 1
End If
Next i
Unique = WorksheetFunction.Sum(Application.Index(Names, 3)) 'Number of MGRs/Names
ReDim RetGross(1 To Months + 1, 1 To (Unique + 1)) 'Setting Size
ReDim Inceptions(1 To 1, 1 To (Unique + 1)) 'Setting Size
Inceptions(1, 1) = "Inception Date ->"
'Building Dates
For i = 1 To Unique
Inceptions(1, i + 1) = Names(2, i)
Next i
Corner = Sheets("ReturnsGross").Range("A2").Offset(0, Unique).Address
'Dropping Dates
Sheets("ReturnsGross").Range("A2:" & Corner) = Inceptions
'Sheets("ReturnsNet").Range("A2:" & Corner) = Inceptions
'Sheets("MarketValues").Range("A2:" & Corner) = Inceptions
RetGross(1, 1) = "Manager Name ->"
RetGross(2, 1) = WorksheetFunction.EoMonth(DateSerial(Year(Sheets("Control").Range("B4")), Month(Sheets("Control").Range("B4")), 1), 0)
'Building Dates
For i = 1 To Months - 1
RetGross(i + 2, 1) = WorksheetFunction.EoMonth(RetGross(i + 1, 1), 1)
Next i
'Building Names
For i = 1 To Unique
RetGross(1, i + 1) = Names(1, i)
Next i
'RetNet = RetGross 'These Lines will have to change
'MValues = RetGross 'These Lines will have to change
'Code to here function correctly
'Grabbing Data Gross
'Grabbing Data
If Sheets("Control").Range("B6") = "#.#" Then
For i = 1 To ColACount - 2
If FullData(i, 3) <= Sheets("Control").Range("B5") And _
FullData(i, 3) >= Sheets("Control").Range("B4") Then
ColNum = WorksheetFunction.Match(FullData(i, 1), Application.Index(RetGross, 1), 0)
RowNum = WorksheetFunction.Match(FullData(i, 3), Application.Index(RetGross, , 1), 0)
If RetGross(RowNum, ColNum) = "" Then 'Prevents overwriting
RetGross(RowNum, ColNum) = FullData(i, 4)
End If
End If
Next i
End If
I have made a userform that allows the user to select a table and add rows to it and fill those rows with various information, all from the userform. I have run into a few problems with this.
First after adding or during adding the items (after hitting submit) excel would crash. It occurs randomly and is hard to reproduce.
Second after running the macro there is a good chance that all the cells in the workbook and every other object except the userform button will stop working, meaning you can't edit interact or even select anything. Then when I close the workbook excel crashes after saving. This is my major offender and I think causes the other problem.
What causes this freezing and why does it occur? How do I fix it? I have looked around and haven't found anything circumstantial. One post said that I should try editing the table with no formatting on it and I did that and it didn't work.
I can provide the excel workbook at a request basis via pm.
The code:
On Activate -
Public Sub UserForm_Activate()
Set cBook = ThisWorkbook
Set dsheet = cBook.Sheets("DATA")
End Sub
Help Checkbox -
Private Sub cbHelp_Click()
If Me.cbHelp.Value = True Then
Me.lbHelp.Visible = True
Else
Me.lbHelp.Visible = False
End If
End Sub
Brand combobox -
Public Sub cmbBrand_Change()
brandTableName = cmbBrand.Value
brandTableName = CleanBrandTableName(brandTableName)
'if brand_edit is not = to a table name then error is thrown
On Error Resume Next
If Err = 380 Then
Exit Sub
Else
cmbItemID.RowSource = brandTableName
End If
On Error GoTo 0
'Set cmbItemID's text to nothing after changing to a new brand
cmbItemID.Text = ""
End Sub
CleanBrandTableName(brandTableName) function -
Option Explicit
Public Function CleanBrandTableName(ByVal brandTableName As String) As String
Dim s As Integer
Dim cleanResult As String
For s = 1 To Len(brandTableName)
Select Case Asc(Mid(brandTableName, s, 1))
Case 32, 48 To 57, 65 To 90, 97 To 122:
cleanResult = cleanResult & Mid(brandTableName, s, 1)
Case 95
cleanResult = cleanResult & " "
Case 38
cleanResult = cleanResult & "and"
End Select
Next s
CleanBrandTableName = Replace(WorksheetFunction.Trim(cleanResult), " ", "_")
End Function
Public Function CleanSpecHyperlink(ByVal specLink As String) As String
Dim cleanLink As Variant
cleanLink = specLink
cleanLink = Replace(cleanLink, "=HYPERLINK(", "")
cleanLink = Replace(cleanLink, ")", "")
cleanLink = Replace(cleanLink, ",", "")
cleanLink = Replace(cleanLink, """", "")
cleanLink = Replace(cleanLink, "Specs", "")
CleanSpecHyperlink = cleanLink
End Function
Browse button -
Public Sub cbBrowse_Click()
Dim rPos As Long
Dim lPos As Long
Dim dPos As Long
specLinkFileName = bFile
rPos = InStrRev(specLinkFileName, "\PDFS\")
lPos = Len(specLinkFileName)
dPos = lPos - rPos
specLinkFileName = Right(specLinkFileName, dPos)
Me.tbSpecLink.Text = specLinkFileName
End Sub
bFile function -
Option Explicit
Public Function bFile() As String
bFile = Application.GetOpenFilename(Title:="Please choose a file to open")
If bFile = "" Then
MsgBox "No file selected.", vbExclamation, "Sorry!"
Exit Function
End If
End Function
Preview button -
Private Sub cbSpecs_Click()
If specLinkFileName = "" Then Exit Sub
cBook.FollowHyperlink (specLinkFileName)
End Sub
Add Item button -
Private Sub cbAddItem_Click()
Dim brand As String
Dim description As String
Dim listPrice As Currency
Dim cost As Currency
Dim Notes As String
Dim other As Variant
itemID = Me.tbNewItem.Text
brand = Me.tbBrandName.Text
description = Me.tbDescription.Text
specLink = Replace(specLinkFileName, specLinkFileName, "=HYPERLINK(""" & specLinkFileName & """,""Specs"")")
If Me.tbListPrice.Text = "" Then
listPrice = 0
Else
listPrice = Me.tbListPrice.Text
End If
If Me.tbCost.Text = "" Then
cost = 0
Else
cost = Me.tbCost.Text
End If
Notes = Me.tbNotes.Text
other = Me.tbOther.Text
If Me.lbItemList.listCount = 0 Then
x = 0
End If
With Me.lbItemList
Me.lbItemList.ColumnCount = 8
.AddItem
.List(x, 0) = itemID
.List(x, 1) = brand
.List(x, 2) = description
.List(x, 3) = specLink
.List(x, 4) = listPrice
.List(x, 5) = cost
.List(x, 6) = Notes
.List(x, 7) = other
x = x + 1
End With
End Sub
Submit button -
Private Sub cbSubmit_Click()
Dim n As Long
Dim v As Long
Dim vTable() As Variant
Dim r As Long
Dim o As Long
Dim c As Long
Dim w As Variant
Set brandTable = dsheet.ListObjects(brandTableName)
o = 1
listAmount = lbItemList.listCount
v = brandTable.ListRows.Count
w = 0
For c = 1 To listAmount
If brandTable.ListRows(v).Range(, 1).Value <> "" Then
brandTable.ListRows.Add alwaysinsert:=True
brandTable.ListRows.Add alwaysinsert:=True
Else
brandTable.ListRows.Add alwaysinsert:=True
End If
Next
ReDim vTable(1000, 1 To 10)
For n = 0 To listAmount - 1
vTable(n + 1, 1) = lbItemList.List(n, 0)
vTable(n + 1, 2) = lbItemList.List(n, 1)
vTable(n + 1, 3) = lbItemList.List(n, 2)
vTable(n + 1, 5) = lbItemList.List(n, 4)
vTable(n + 1, 6) = lbItemList.List(n, 5)
vTable(n + 1, 7) = lbItemList.List(n, 6)
vTable(n + 1, 8) = lbItemList.List(n, 7)
If lbItemList.List(n, 3) = "" Then
ElseIf lbItemList.List(n, 3) <> "" Then
vTable(n + 1, 4) = lbItemList.List(n, 3)
End If
If n = 0 And brandTable.DataBodyRange(1, 1) <> "" Then
For r = 1 To brandTable.ListRows.Count
If brandTable.DataBodyRange(r, 1) <> "" Then
o = r + 1
' brandTable.ListRows.Add alwaysinsert:=True
End If
Next
End If
brandTable.ListColumns(1).DataBodyRange(n + o).Value = vTable(n + 1, 1)
brandTable.ListColumns(2).DataBodyRange(n + o).Value = vTable(n + 1, 2)
brandTable.ListColumns(3).DataBodyRange(n + o).Value = vTable(n + 1, 3)
brandTable.ListColumns(4).DataBodyRange(n + o).Value = vTable(n + 1, 4)
brandTable.ListColumns(5).DataBodyRange(n + o).Value = vTable(n + 1, 5)
brandTable.ListColumns(6).DataBodyRange(n + o).Value = vTable(n + 1, 6)
brandTable.ListColumns(7).DataBodyRange(n + o).Value = vTable(n + 1, 7)
brandTable.ListColumns(8).DataBodyRange(n + o).Value = vTable(n + 1, 8)
Next
brandTable.DataBodyRange.Select
Selection.Font.Bold = True
Selection.WrapText = True
brandTable.ListColumns(5).DataBodyRange.Select
Selection.NumberFormat = "$#,##0.00"
brandTable.ListColumns(6).DataBodyRange.Select
Selection.NumberFormat = "$#,##0.00"
Unload Me
End Sub
Remove Items button -
Private Sub cbRemoveItems_Click()
Dim intCount As Long
For intCount = lbItemList.listCount - 1 To 0 Step -1
If lbItemList.Selected(intCount) Then
lbItemList.RemoveItem (intCount)
x = x - 1
End If
Next intCount
End Sub
There is other code that does things for the other tabs but they don't interact with this tabs code.
I have a vba code that find the value at the intersection of columns and rows.
It works well with all my data except for one : it returns NA.
The value i want to return is the same as usual, it just doesn't work with this intersection.
Can you help me figure out why?
Thank you
With Perftitres
Set VMt = Data1.Range("U:U")
Set Ticker = Data1.Range("H:H")
End With
' Calculs de perf
For Each sht In Perftitres.Worksheets
If sht.Visible = True Then
If sht.Cells(1, 1) = "" Then
sht.Cells(1, 1) = "Date"
sht.Cells(1, 2) = "Code du placement"
sht.Cells(1, 3) = "Valeur marchande t"
sht.Cells(1, 4) = "Valeur marchande t-1"
sht.Cells(1, 5) = "Valeur des achats"
sht.Cells(1, 6) = "Valeur des ventes"
sht.Cells(1, 7) = "Facteur"
sht.Cells(1, 8) = "Rendement 1 mois"
End If
LastRowsht = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
LastColumnsht = sht.Cells(1, sht.Columns.Count).End(xlToLeft).Column
sht.Cells(LastRowsht + 1, 1) = 20 & Left(Dateupdate, 2) & "-" & Right(Dateupdate, 2)
sht.Cells(LastRowsht + 1, 2) = sht.Name
sht.Cells(LastRowsht + 1, 3) = Application.Index(VMt, Application.Match(sht.Cells(LastRowsht + 1, 2), Ticker))
End If
Next sht
Data1.Visible = True
Data2.Visible = True
This line doesn't work as expected for only one sheet. For every other one it works.
sht.Cells(LastRowsht + 1, 3) = Application.Index(VMt, Application.Match(sht.Cells(LastRowsht + 1, 2), Ticker))
I just found the answer :
sht.Cells(LastRowsht + 1, 3) = Application.Index(VMt, Application.Match(sht.Cells(LastRowsht + 1, 2), Ticker,0),0)
I had to had 0 and 0 for exact matches