i Have the followin code in vb
Dim sStart As String, sEnd As String
sStart = ComboBoxYear.List(ComboBoxYear.ListIndex) & "-" & ComboBoxMonth.List(ComboBoxMonth.ListIndex) & "-1"
sEnd = Format(DateAdd("M", 1, CDate(sStart)) - 1, "yyyy-MMM-dd")
Now i have changed this in VB.NET as
sStart = Me.ComboBoxYear.SelectedItem.ToString() & "-" & ComboBoxMonth.SelectedItem.ToString() & "-1"
sEnd = Format(DateAdd("M", 1, CDate(sStart)) & -1, "yyyy-MMM-dd")
But sEnd giving result as 'yyyy-MMM-dd' only, what i did wrong in my code.
Try Like This
sStart = Me.ComboBoxYear.SelectedItem.ToString() & "-" &
ComboBoxMonth.SelectedItem.ToString() & "-1"
sEnd =Format(CDate(DateAdd("M", 1, CDate(sStart)) & -1), "yyyy-MMM-dd")
Add CDate inside of DateAdd("M", 1, CDate(sStart)) & -1
Related
Please have at look on my issue.
Background data: ItemB - field with date type, which has YYMMDDHHNN format
inptdate - textBox for input data in YYMMDDHHNN format
What needed, transform data from String format (inptdate) into Date format(ItemB)
My way
Private Sub Idate_AfterUpdate()
Dim mydate As String
mydate = "2212131400"
inptdate= mydate
Me.ItemB = CDate(Mid(mydate, 6, 2) & "," & Mid(mydate, 4, 2) & "," & Mid(mydate, 2, 2) & " " & Mid(mydate, 8, 2) & ":" & Mid(mydate, 10, 2))
End Sub
but my code execute with an "Type mismatch" error
You can use Format and CDate:
Dim TrueDate As Date
mydate = "2212131400"
TrueDate = CDate("20" & Format(mydate, "##\/##\/## ##\:##"))
I want to be able to add together the individual digits of a 4 digit number, but it does not seem to work.
I am doing this purely in VBA code. The result is output to a worksheet.
I have extracted part of my code and put it into a separate macro to test it and still get the same result. It concatenates the digits together.
I have added in lots of msgbox lines to see what it is doing, but cannot work out why, in this case, the value of main is not added up into the intm variable.
The variables intd1 to intd4 get the values correctly, but when I try to add them together into intm, it just concatenates them together.
Sub AddDigits()
'
' Add individual digits of number together
'
Dim intd1, intd2, intd3, intd4, main, intm As Integer
main = 1234
intd1 = Left(main, 1)
MsgBox (intd1)
intd2 = Mid(main, 2, 1)
MsgBox (intd2)
intd3 = Mid(main, 3, 1)
MsgBox (intd3)
intd4 = Right(main, 1)
MsgBox (intd4)
intm = intd1 + intd2 + intd3 + intd4
MsgBox ("intm = " & intm & Chr(13) & _
"intd1 = " & intd1 & Chr(13) & _
"intd2 = " & intd2 & Chr(13) & _
"intd3 = " & intd3 & Chr(13) & _
"intd4 = " & intd4 & Chr(13))
End Sub
When you declare the variables the way you did, the first bit are all "variants", and VBA your use of Mid, Left, and Right are all string functions, so VBA coverts the variant to Strings:
If you dim your variables properly, you get the expected result:
Sub AddDigits()
'
' Add individual digits of number together
'
Dim intd1 As Integer, _
intd2 As Integer, _
intd3 As Integer, _
intd4 As Integer, _
main As Integer, _
intm As Integer
main = 1234
intd1 = Left(main, 1)
MsgBox (intd1)
intd2 = Mid(main, 2, 1)
MsgBox (intd2)
intd3 = Mid(main, 3, 1)
MsgBox (intd3)
intd4 = Right(main, 1)
MsgBox (intd4)
intm = intd1 + intd2 + intd3 + intd4
MsgBox ("intm = " & intm & Chr(13) & _
"intd1 = " & intd1 & Chr(13) & _
"intd2 = " & intd2 & Chr(13) & _
"intd3 = " & intd3 & Chr(13) & _
"intd4 = " & intd4 & Chr(13))
End Sub
In addition to the above answer, you can also convert the data type anywhere later in the code. To convert anything to int use Cint. Similarly for other type conversion you check the link
intm = CInt(intd1) + CInt(intd2) + CInt(intd3) + CInt(intd4)
I need to get a popup box to appear asking the user to input a date. I want to ensure only dates in the DD/MM/YYYY format can be uploaded.
The below code works, however it allows for any input type to be inserted:
Call RunSQL("UPDATE Summary " & _
"SET " & _
"Date_of_Report = [Enter the Report date in the following format DD/MM/YYYY, with the DD being the last day of the month] " & _
" WHERE Date_of_Report IS NULL ")
I also want to include the name of the file that is being updated in the prompt I tried do the following (where FileNameSelected is a variable that will contain a different value each time), but get an error:
Call RunSQL("UPDATE Summary " & _
"SET " & _
"Date_of_Report = [Enter the Report date for the '" & FileNameSelected & "' file in the following format DD/MM/YYYY, with the DD beng the last day of the month] " & _
" WHERE Date_of_Report IS NULL ")
I would really appreciate if anyone could tell me how to set parameters around the format and also include the value of the FileNameSelected variable in the prompt.
Also for VBA popup boxes I know you use & vbCrLf & _ to create a new line for he message box, how do I do this with a prompt?
That's how I would validate your date. It would be a lot easier with MM/DD/YYYY format. With DD/MM you have to entirely deal with it or you have a risk that Access mixes months and days.
Public Sub Test_date_prompt()
Dim strInpput As String
Dim dtConverted As Date
Dim OK As Boolean
Dim FileNameSelected As String
On Error GoTo Err_handler
OK = False
FileNameSelected = "Anything for this example"
strinput = InputBox("Enter the Report date for the '" & FileNameSelected & "' file in the following format DD/MM/YYYY, with the DD being the last day of the month", "Enter date")
' testing if user inputed 10 characters
If Len(strinput) = 10 Then
' testing if / separators are at the right place
If Mid(strinput, 3, 1) = "/" And Mid(strinput, 6, 1) = "/" Then
' testing if DD, MM, YYYY placeholders are all numeric
If IsNumeric(Left(strinput, 2)) And IsNumeric(Mid(strinput, 4, 2)) And IsNumeric(Right(strinput, 4)) Then
'looks good
OK = True
End If
End If
End If
If Not OK Then
' not good, abording process
MsgBox "You have not entered a valid date in DD/MM/YYYY format !", vbExclamation, "Abording"
GoTo Exit_Sub
End If
' Converting in date which ensure a valid date, otherwise an error will occur
dtConverted = DateSerial(Right(strinput, 4), Mid(strinput, 4, 2), Left(strinput, 2))
' if your Date_of_report type is DATE, do :
' Call RunSQL("UPDATE Summary " & _
"SET " & _
"Date_of_Report = #" & Format(dtConverted, "MM/DD/YYYY") & "# " & _
" WHERE Date_of_Report IS NULL ")
' if your Date_of_report type is STRING (bad!), do :
' Call RunSQL("UPDATE Summary " & _
"SET " & _
"Date_of_Report = '" & Format(dtConverted, "DD/MM/YYYY") & "' " & _
" WHERE Date_of_Report IS NULL ")
Exit_Sub:
Exit Sub
Err_handler:
MsgBox Err.Description
Resume Exit_Sub
End Sub
I'm collecting metric values from many different worksheets in one overview sheet which will be used for generating a PowerBI dashboard.
Below is my code, i'm new to vba so it's probably not so elegant, but works for what i need, except for one thing.
Some of the metric values in these sheets are integers, others have data type percentage.
If the value in the metric sheet has number format %, for example "10" formatted as %, it gets taken as 0,1 with the current code i have. I would like to multiply these percentages with 100 and add this number in the overview sheet. But I have difficulties finding out how i can extract the data type and if a percentage, multiply with 100, and if no percentage, get the value as is. Would anyone be able to help with that?
Many thanks in advance -
Function HasSheet(fPath As String, fName As String, sheetName As String)
On Error Resume Next
Dim f As String
f = "'" & fPath & "[" & fName & "]" & sheetName & "'!R1C1"
HasSheet = Not IsError(Application.ExecuteExcel4Macro(f))
If Err.Number <> 0 Then
HasSheet = False
End If
On Error GoTo 0
End Function
Sub CollectMetrics()
Dim id As Integer
Dim Ind As String
Dim MetricName As String
Dim Include1 As String
Dim Include2 As String
Dim Segment As String
Dim file As String
Dim filepath As String
Dim filename As String
Dim s As Boolean
Dim D As Date
Dim MonthNbr As Integer
Set sh1 = Worksheets("Metrics")
Set sh2 = Worksheets("Metadata")
NumRows = sh1.Range("A1", sh1.Range("A1").End(xlDown)).Rows.Count
For id = 2 To NumRows
MetricName = sh1.Range("A" & id).Value
Include1 = Application.WorksheetFunction.VLookup(MetricName, sh2.Range("B2:L100"), 9, True)
Include2 = Application.WorksheetFunction.VLookup(MetricName, sh2.Range("B2:L100"), 10, True)
Ind = Application.WorksheetFunction.VLookup(MetricName, sh2.Range("B2:L100"), 2, True)
filename = Ind & " " & MetricName & " 2018.xlsx"
If Include1 = "auto" And Include2 = "yes" Then
Segment = sh1.Range("B" & id).Value
file = "='https://xxx/[" & filename & "]" & Segment
filepath = "https://xxx/"
s = HasSheet(filepath, filename, Segment)
If s Then
D = sh1.Range("C" & id).Value
MonthNbr = Month(D)
sh1.Range("D" & id).Value = file & "'!D" & (MonthNbr + 13)
sh1.Range("E" & id).Value = file & "'!E" & (MonthNbr + 13)
sh1.Range("F" & id).Value = file & "'!F" & (MonthNbr + 13)
sh1.Range("G" & id).Value = file & "'!G" & (MonthNbr + 13)
sh1.Range("J" & id).Value = file & "'!D" & (MonthNbr + 40)
sh1.Range("K" & id).Value = file & "'!E" & (MonthNbr + 40)
sh1.Range("L" & id).Value = file & "'!F" & (MonthNbr + 40)
sh1.Range("M" & id).Value = file & "'!G" & (MonthNbr + 40)
sh1.Range("O" & id).Value = "values updated on " & Format(Now(), "dd-mm-yy")
Else
sh1.Range("O" & id).Value = "sheet available but segment missing"
End If
ElseIf Include2 = "no" Then
sh1.Range("O" & id).Value = "metric set to not yet include"
ElseIf Include1 = "manual" Then
sh1.Range("O" & id).Value = "metric to be manually updated"
End If
Next
MsgBox (" Update completed! ")
End Sub
I would try to avoid multiplying a percentage by 100 and adding a percent symbol, if there's the option to do it the "right way".
It's not a huge problem in this case, it's just better to create good habits. (And just for the record, the reason 10% gets taken as 0,1 is because 10% is 0,1.
Nonetheless, we need an easy way to display it as a percentage instead of a fraction of 1 (when applicable), and as with many tasks in Excel, there are multiple ways to accomplish the same thing.
This way took me the least thought:
Range("B1") = Range("A1") 'copies the value
Range("B1").NumberFormat = Range("A1") .NumberFormat 'copies the number format.
Changes I made:
The "cleanest" way to do this was with a small sub called copyNumber and adjusting the affected lines to use the new procedure.
I tidied indentation - which is important for organization and readability.
I added Option Explicit which is a good idea to have at the beginning of every module, to help recognize oversights such as...
sh1 and sh2 were not declared as Worksheets, so I added Dim statements for them - but squished them onto a line shared with their Set statements with : colons.
The other changes I made were purely cosmetic and more of a matter of perference, and obviously if you don't like those changes, don't use them. :-)
I got rid of the ElseIf's - I don't like them for the same reason indentation is important.
I used With..End statements to remove repetitive code (like Sh1. and Application.WorksheetFunction.)
I squished the variable declaration (Dim statements) from "a page" into 3 lines.
Adjusted Code:
Option Explicit
Function HasSheet(fPath As String, fName As String, sheetName As String)
On Error Resume Next
Dim f As String
f = "'" & fPath & "[" & fName & "]" & sheetName & "'!R1C1"
HasSheet = Not IsError(Application.ExecuteExcel4Macro(f))
If Err Then HasSheet = False
On Error GoTo 0
End Function
Sub copyNumber(rgeSrc As Range, rgeDest As Range)
rgeDest.Value = rgeSrc.Value ' copy number
rgeDest.NumberFormat = rgeSrc.NumberFormat ' copy number format
End Sub
Sub CollectMetrics()
Dim MetricName As String, Segment As String, Ind As String, Include1 As String, Include2 As String
Dim file As String, filePath As String, fileName As String
Dim MonthNbr As Integer, id As Integer, numRows As Integer
Dim sh1 As Worksheet: Set sh1 = Worksheets("Metrics")
Dim sh2 As Worksheet: Set sh2 = Worksheets("Metadata")
With sh1
numRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
For id = 2 To numRows
MetricName = Range("A" & id)
With Application.WorksheetFunction
Include1 = .VLookup(MetricName, sh2.Range("B2:L100"), 9, True)
Include2 = .VLookup(MetricName, sh2.Range("B2:L100"), 10, True)
Ind = .VLookup(MetricName, sh2.Range("B2:L100"), 2, True)
End With
fileName = Ind & " " & MetricName & " 2018.xlsx"
If Include1 = "auto" And Include2 = "yes" Then
Segment = Range("B" & id)
file = "='https://xxx/[" & fileName & "]" & Segment
filePath = "https://xxx/"
If HasSheet(filePath, fileName, Segment) Then
MonthNbr = Month(Range("C" & id))
copyNumber .Range("D" & id), Range(file & "'!D" & (MonthNbr + 13))
copyNumber .Range("E" & id), Range(file & "'!E" & (MonthNbr + 13))
copyNumber .Range("F" & id), Range(file & "'!F" & (MonthNbr + 13))
copyNumber .Range("G" & id), Range(file & "'!G" & (MonthNbr + 13))
copyNumber .Range("J" & id), Range(file & "'!D" & (MonthNbr + 40))
copyNumber .Range("K" & id), Range(file & "'!E" & (MonthNbr + 40))
copyNumber .Range("L" & id), Range(file & "'!F" & (MonthNbr + 40))
copyNumber .Range("M" & id), Range(file & "'!G" & (MonthNbr + 40))
Range("O" & id) = "Values updated on " & Format(Now(), "dd-mm-yy")
Else
Range("O" & id) = "Sheet available but segment missing"
End If
Else
If Include2 = "no" Then
Range("O" & id) = "Metric set to not yet include"
Else
If Include1 = "manual" Then Range("O" & id) = "Metric to be manually updated"
End If
End If
Next id
End With
MsgBox "Update completed!"
End Sub
Just in case someone is looking for this approach in future, here is the final code i used:
Option Explicit
Function HasSheet(fPath As String, fName As String, sheetName As String)
On Error Resume Next
Dim f As String
f = "'" & fPath & "[" & fName & "]" & sheetName & "'!R1C1"
HasSheet = Not IsError(Application.ExecuteExcel4Macro(f))
If Err Then HasSheet = False
On Error GoTo 0
End Function
Sub CollectMetrics()
Dim MetricName As String, Segment As String, Ind As String, Include1 As String, Include2 As String, Include3 As String
Dim file As String, filePath As String, fileName As String
Dim MonthNbr As Integer, id As Integer, numRows As Integer
Dim sh1 As Worksheet: Set sh1 = Worksheets("Metrics")
Dim sh2 As Worksheet: Set sh2 = Worksheets("Metadata")
With sh1
numRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
For id = 2 To numRows
MetricName = Range("A" & id)
With Application.WorksheetFunction
Include1 = .VLookup(MetricName, sh2.Range("B2:L100"), 9, True)
Include2 = .VLookup(MetricName, sh2.Range("B2:L100"), 10, True)
Include3 = .VLookup(MetricName, sh2.Range("B2:L100"), 11, True)
Ind = .VLookup(MetricName, sh2.Range("B2:L100"), 2, True)
End With
fileName = Ind & " " & MetricName & " 2018.xlsx"
If Include1 = "auto" And Include2 = "yes" Then
Segment = Range("B" & id)
file = "='https://xxxx/[" & fileName & "]" & Segment
filePath = "https://xxxx/"
If HasSheet(filePath, fileName, Segment) Then
MonthNbr = Month(Range("C" & id))
sh1.Range("D" & id).Value = file & "'!D" & (MonthNbr + 13)
sh1.Range("E" & id).Value = file & "'!E" & (MonthNbr + 13)
sh1.Range("F" & id).Value = file & "'!F" & (MonthNbr + 13)
sh1.Range("G" & id).Value = file & "'!G" & (MonthNbr + 13)
sh1.Range("H" & id).Value = file & "'!B" & (MonthNbr + 13) 'Actuals KPI Index
Select Case sh1.Range("H" & id).Value
Case "R"
sh1.Range("H" & id).Value = "3"
Case "Y"
sh1.Range("H" & id).Value = "2"
Case "G"
sh1.Range("H" & id).Value = "1"
End Select
sh1.Range("I" & id).Value = file & "'!D" & (MonthNbr + 40)
sh1.Range("J" & id).Value = file & "'!E" & (MonthNbr + 40)
sh1.Range("K" & id).Value = file & "'!F" & (MonthNbr + 40)
sh1.Range("L" & id).Value = file & "'!G" & (MonthNbr + 40)
sh1.Range("M" & id).Value = file & "'!B" & (MonthNbr + 13) 'YTD KPI Index
Select Case sh1.Range("M" & id).Value
Case "R"
sh1.Range("M" & id).Value = "3"
Case "Y"
sh1.Range("M" & id).Value = "2"
Case "G"
sh1.Range("M" & id).Value = "1"
End Select
Range("N" & id) = "Values updated on " & Format(Now(), "dd-mm-yy")
If Include3 = "%" Then ' multiply with 100 for percentages
sh1.Range("D" & id).Value = (sh1.Range("D" & id).Value) * 100
sh1.Range("E" & id).Value = (sh1.Range("E" & id).Value) * 100
sh1.Range("F" & id).Value = (sh1.Range("F" & id).Value) * 100
sh1.Range("G" & id).Value = (sh1.Range("G" & id).Value) * 100
sh1.Range("I" & id).Value = (sh1.Range("I" & id).Value) * 100
sh1.Range("J" & id).Value = (sh1.Range("J" & id).Value) * 100
sh1.Range("K" & id).Value = (sh1.Range("K" & id).Value) * 100
sh1.Range("L" & id).Value = (sh1.Range("L" & id).Value) * 100
End If
Else
Range("N" & id) = "Sheet available but segment missing"
End If
Else
If Include2 = "no" Then
Range("N" & id) = "Metric set to not yet include"
Else
If Include1 = "manual" Then Range("N" & id) = "Metric to be manually updated"
End If
End If
Next id
End With
MsgBox "Update completed!"
End Sub
I'm developing a userform, and have a listbox in it. I'm loading the listbox, but only with select data, and based on different dropdowns in the userform as well. The sample sheet I have goes through 6000 lines, but I'm being told that it will eventually include 20,000+. It's already taking around ten seconds to filter. Is there a more efficient way of doing this?
Code is below:
For rowNum = isStartRow To isEndRow
Dim h2T As String: h2T = iSH.Range(h2 & rowNum).Text
Dim h3T As String: h3T = iSH.Range(h3 & rowNum).Text
Dim h4T As String: h4T = iSH.Range(h4 & rowNum).Text
Dim h5T As String: h5T = iSH.Range(h5 & rowNum).Text
Dim descT As String: descT = UCase(iSH.Range(desc & rowNum).Text)
If h2T Like "*" & Me.cmbo_H2.value & "*" And h3T Like "*" & Me.cmbo_H3.value & "*" And h4T Like "*" & Me.cmbo_H4.value & "*" And h5T Like "*" & Me.cmbo_H5.value & "*" And descT Like "*" & UCase(Me.txt_Search.value) & "*" And (iSH.Range("A" & rowNum) = 10 Or iSH.Range("A" & rowNum) = 20) Then
If Not Exists(Me.cmbo_H2, h2T) Then Me.cmbo_H2.AddItem h2T
If Not Exists(Me.cmbo_H3, h3T) Then Me.cmbo_H3.AddItem h3T
If Not Exists(Me.cmbo_H4, h4T) Then Me.cmbo_H4.AddItem h4T
If Not Exists(Me.cmbo_H5, h5T) Then Me.cmbo_H5.AddItem h5T
Me.list_Items.AddItem iSH.Range(desc & rowNum).Text
Me.list_Items.List(Me.list_Items.ListCount - 1, 1) = iSH.Range(codeCol & rowNum).Text
Me.list_Items.List(Me.list_Items.ListCount - 1, 2) = iSH.Range(iNumber & rowNum).Text
Me.list_Items.List(Me.list_Items.ListCount - 1, 3) = iSH.Range(moqCol & rowNum).Text
End If
Next
a more efficient way would be to read the range into an array and then do all processing within the array. Reading the sheet is costly in terms of processing time, read it once to an array and then process
This may help you http://www.cpearson.com/excel/ArraysAndRanges.aspx