I am working on Excel sheet that enables a user to save data to Sheet2 from a vbForm in Sheet1.
The Form has a ComboBox with a List (Jan, Feb, March...) but I want when a user selects Jan, the Value Saves as 1, Feb as 2 and so on.
Here is my code..
```Sub Submit()
Dim sh As Worksheet
Dim iRow As Long
Set sh = ThisWorkbook.Sheets("Database")
iRow = [Counta(Database!A:A)] + 1
With sh
.Cells(iRow, 1) = iRow - 1
.Cells(iRow, 2) = frmForm.txtAdm.Value
.Cells(iRow, 3) = frmForm.txtIndexno.Value
.Cells(iRow, 4) = frmForm.cmbMonth.Value = Z
End With
End Sub
Private Sub cmbMonth_Change()
If cmbMonth.Text = "January" Then
Z = 1
ElseIf cmbMonth.Text = "February" Then
Z = 2
ElseIf cmbMonth.Text = "March" Then
Z = 3
End If
End Sub```
If you need a compact code to transform the months name in their number, please use the next way:
Private Sub cmbMonth_Change()
Dim arrMonths, mtch, Z As Long
arrMonths = Split("January,February,March,April,May,June,July,August,September,October,November,December", ",")
mtch = Application.match(cmbMonth.Value, arrMonths, 0)
If IsNumeric(mtch) Then
Z = mtch
Else
'Just in case:
Msgbox "The combo value is not a month name..."
End If
End Sub
Related
I am having a issue to auto fill data from another sheet, I am trying to enter "sku" Value in Sheet(Report), then auto fill both "Store name" & "qty" from another Sheet(SOH). However, if the last row of the "store name" (Column A, Report Sheet) = Blank, this Marco will not working properly, otherwise it is working fine. Did I miss something? Any help would be greatly appreciated!!
Sub Fill_Report()
Dim d, s As Long
Dim sQTY As Double
Dim dws, sws As Worksheet
Set dws = ThisWorkbook.Worksheets("Report") 'Destination Sheet
Set sws = ThisWorkbook.Worksheets("SOH") 'Source Sheet
dlr = dws.Cells(Rows.Count, 1).End(xlUp).Row
slr = sws.Cells(Rows.Count, 1).End(xlUp).Row
For d = 2 To dlr
For s = 2 To slr
ssku = sws.Cells(s, "A:A").Value
dsku = dws.Cells(d, "B:B").Value
'Index qty from source
sQTY = Application.IfError(Application.Index(Sheets("SOH").Range("A:Z"), _
Application.Match(ssku, Sheets("Report").Range("B:B"), 0), 2), 0)
'add title
dws.Cells(1, 1).Value = "Sotre Name"
dws.Cells(1, 2).Value = "sku"
dws.Cells(1, 3).Value = "qty"
If dsku = ssku Then
dws.Cells(d, "A").Value = "ABC"
dws.Cells(d, "C").Value = sQTY
Exit For
End If
Next s
Next d
End Sub
Collections and Dictionaries are optimized for fast lookups. Consider using them over Match and Index.
Range("A1").CurrentRegion will select the entire range of contiguous cells.
Sub Fill_Report()
Dim Quantities As New Collection
Set Quantities = getSKUQuantity
Dim Data As Variant
Data = wsReport.Range("A1").CurrentRegion.Columns("B").Offset(1)
Dim r As Long
Dim QTY As Double
For r = r To UBound(Data)
On Error Resume Next
QTY = Quantities(Data(r, 1))
If Err.Number = 0 Then
Data(r, 1) = QTY
Else
Data(r, 1) = ""
End If
On Error GoTo 0
Next
wsReport.Range("A1").CurrentRegion.Columns("C").Offset(1).Value = Data
End Sub
Function getSKUQuantity() As Collection
Dim Data As Variant
Data = wsSOH.Range("A1").CurrentRegion
Dim Quantities As New Collection
Dim r As Long
For r = 2 To UBound(Data)
On Error Resume Next
If Err.Number = 0 Then
Quantities.Add Data(r, 2), CStr(Data(r, 1))
Else
Debug.Print "Duplicate SKU: ", Data(r, 1)
End If
On Error GoTo 0
Next
Set getSKUQuantity = Quantities
End Function
Function wsSOH() As Worksheet
Set wsSOH = ThisWorkbook.Sheets("SOH")
End Function
Function wsReport() As Worksheet
Set wsReport = ThisWorkbook.Sheets("Report")
End Function
The below macros works for - I have a workbook with two sheets (Active and Archive). And in Active sheet i have AB column that contains Active or Archive status. If its status Archive macros cuts and moves the row to the sheet Archive. This macros works perfect.
Now i need to add some other sheets to excel and named them (New, Accepted, Rejected) and of course i add the same status to the column AB. Now i want macros to do the same if AB = Archive or New or Accepted or Rejected cut and move the row to the sheet named Archive or New or Accepted or Rejected.
I tried it by myself but can't do it.
Need ur help. Thanks in advance.
Private Sub CommandButton1_Click()
Dim x As Integer
Dim y As Integer
Dim i As Integer
Dim shSource As Worksheet
Dim shTarget1 As Worksheet
Set shSource = ThisWorkbook.Sheets("Active")
Set shTarget1 = ThisWorkbook.Sheets("Archive")
If shTarget1.Cells(2, 28).Value = "" Then
x = 2
Else
x = shTarget1.Cells(2, 28).CurrentRegion.Rows.Count + 1
End If
i = 2
Do Until shSource.Cells(i, 28) = ""
If shSource.Cells(i, 28).Value = "Archive" Then
shSource.Rows(i).Copy
shTarget1.Cells(x, 1).PasteSpecial Paste:=xlPasteValues
shSource.Rows(i).Delete
x = x + 1
GoTo Line1
End If
i = i + 1
Line1: Loop
End Sub
You can set up multiple variables and choose the right ones in a select case. There is some repetition here that could get cleaned up with arrays.
Sub CommandButton1_Click()
Dim x As Integer 'archive target counter
Dim y As Integer 'new target counter
Dim z As Integer 'accepted target counter
Dim w As Integer 'rejected target counter
'the above could be an array if we were trying to generalize
Dim i As Integer 'counts rows in original sheet
Dim shSource As Worksheet
Dim shTarget1 As Worksheet 'archive sheet
Dim shTarget2 As Worksheet 'new sheet
Dim shTarget3 As Worksheet 'accepted sheet
Dim shTarget4 As Worksheet 'rejected sheet
'these 4 could also be an array, as could their names, in which case some things become loops and the select case could be written out
Set shSource = ThisWorkbook.Sheets("Active")
Set shTarget1 = ThisWorkbook.Sheets("Archive")
Set shTarget2 = ThisWorkbook.Sheets("New")
Set shTarget3 = ThisWorkbook.Sheets("Accepted")
Set shTarget4 = ThisWorkbook.Sheets("Rejected")
If shTarget1.Cells(2, 28).Value = "" Then
x = 2
Else
x = shTarget1.Cells(2, 28).CurrentRegion.Rows.Count + 1
End If
If shTarget2.Cells(2, 28).Value = "" Then
y = 2
Else
y = shTarget2.Cells(2, 28).CurrentRegion.Rows.Count + 1
End If
If shTarget3.Cells(2, 28).Value = "" Then
z = 2
Else
z = shTarget3.Cells(2, 28).CurrentRegion.Rows.Count + 1
End If
If shTarget4.Cells(2, 28).Value = "" Then
w = 2
Else
w = shTarget4.Cells(2, 28).CurrentRegion.Rows.Count + 1
End If
i = 2
Do Until shSource.Cells(i, 28) = ""
Select Case shSource.Cells(i, 28).Value
Case "Archive":
shSource.Rows(i).Copy
shTarget1.Cells(x, 1).PasteSpecial Paste:=xlPasteValues
shSource.Rows(i).Delete
x = x + 1
Case "New":
shSource.Rows(i).Copy
shTarget2.Cells(y, 1).PasteSpecial Paste:=xlPasteValues
shSource.Rows(i).Delete
y = y + 1
Case "Accepted":
shSource.Rows(i).Copy
shTarget3.Cells(z, 1).PasteSpecial Paste:=xlPasteValues
shSource.Rows(i).Delete
z = z + 1
Case "Rejected":
shSource.Rows(i).Copy
shTarget4.Cells(w, 1).PasteSpecial Paste:=xlPasteValues
shSource.Rows(i).Delete
w = w + 1
Case Else 'no cutting so move to next input line
i = i + 1
End Select
Loop
End Sub
EDIT: Below is the array based version that repeats itself less. Also, I found I kept overwriting my top row in the target sheets, so I added 2 (not 1) to the target counters when I initialized them. If the original was working in your context, you may switch it back.
Sub CommandButton1_Click()
Dim TargetCounters(3) As Integer
Dim TargetNames(3) As String
TargetNames(0) = "Archive"
TargetNames(1) = "New"
TargetNames(2) = "Accepted"
TargetNames(3) = "Rejected"
Dim i As Integer 'counts rows in original sheet
Dim shSource As Worksheet
Dim shTargets(3) As Worksheet
Set shSource = ThisWorkbook.Sheets("Active")
For i = 0 To 3
Set shTargets(i) = ThisWorkbook.Sheets(TargetNames(i))
If shTargets(i).Cells(2, 28).Value = "" Then
TargetCounters(i) = 2
Else 'there is stuff. Imagine for example it is in rows 2 to 7. Count will be 6. We need to start pasting in row 8
TargetCounters(i) = shTargets(i).Cells(2, 28).CurrentRegion.Rows.Count + 2 'changed this from orinal + 1
End If
Next i
i = 2
Dim MatchIndex As Integer
Do Until shSource.Cells(i, 28).Value = ""
'you could switch this case to a call on the application's match function against TargetNames
'if you take care with the case where it is not found and indexing being right and not off by 1
Select Case shSource.Cells(i, 28).Value
Case "Archive":
MatchIndex = 0
Case "New":
MatchIndex = 1
Case "Accepted":
MatchIndex = 2
Case "Rejected":
MatchIndex = 3
Case Else 'no cutting so set signal and we will move to next input line
MatchIndex = -1
End Select
If (MatchIndex = -1) Then
i = i + 1
Else
shSource.Rows(i).Copy
shTargets(MatchIndex).Cells(TargetCounters(MatchIndex), 1).PasteSpecial Paste:=xlPasteValues
shSource.Rows(i).Delete
TargetCounters(MatchIndex) = TargetCounters(MatchIndex) + 1
End If
Loop
End Sub
Hi I am Trying to add to cells together and compare them against another cell but I get a type mismatch.
first cell is a date, the one being added is a number"as in number of days" and the third one being compared is a date also.
but I get type mismatch.
my code is below
Sub Macro1()
Macro1 Macro
Dim wks As Worksheet
Set wks = ActiveSheet
Dim x As Integer
Dim p As Integer
Dim rowRange As Range
Dim colRange As Range
Dim LastCol As Long
Dim LastRow As Long
LastRow = wks.Cells(wks.Rows.Count, "A").End(xlUp).Row
Set rowRange = wks.Range("A1:A" & LastRow)
For i = 7 To 189
p = 0
For q = 8 To LastRow
If [aq] = [si] Then
If [cq] + [ui] >= [xi] Then
[oq] = 1
Else
p = p + [dq]
[qq] = 0
End If
End If
Next q
Next i
End Sub
[cq] is a cell that contains date
[ui] is a cell that contains number
[xi] is a cell that contains date
Try it as cells(q, "A") = cells(i, "S").
For i = 7 To 189
p = 0
For q = 8 To LastRow
'If [aq] = [si] Then
If cells(q, "A") = cells(i, "S") Then
'If [cq] + [ui] >= [xi] Then
If cells(q, "C") + cells(i, "U") >= cells(i, "X") Then
'[oq] = 1
cells(q, "O") = 1
Else
'p = p + [dq]
p = p + cells(q, "D")
'[qq] = 0
cells(q, "Q") = 0
End If
End If
Next q
Next i
You need to use the "DateAdd" function. Instructions here: https://www.techonthenet.com/excel/formulas/dateadd.php
Example:
Sub add_dates()
Dim dateOne As Date
Dim dateTwo As Date
Dim lngDays As Long
dateOne = "1/1/2018"
lngDays = 2
dateTwo = "1/3/2018"
Dim result As Boolean
If DateAdd("d", lngDays, dateOne) >= dateTwo Then
MsgBox ("Greater than or equal to")
Else
MsgBox ("Less than")
End If
End Sub
Here is an example of what I am trying to accomplish:
I am trying to add an "x" in the next 3 blank cells that are next to a nonblank cell (from left to right). I do not want to overwrite any cells though. As you can see in the first row, only December and January are filled and I did not overwrite February.
Any ideas?
Sub sub1()
Dim irow&, icol&, n&
For irow = 2 To 6 ' rows
n = 0
For icol = 2 To 14 ' columns
If Cells(irow, icol) = "" Then
n = n + 1
If n <= 3 Then Cells(irow, icol) = "x"
Else
n = 0
End If
Next
Next
End Sub
For Each ID In Range("A2:A6") 'Change your range according your ID
For Each cell In ID.EntireRow.Cells 'Check each cell of ID's row
If cell.Value = "" Then
cell.Value = "x"
No = No + 1
Else
No = 0 'Recount
End If
If No = 3 Then Exit For 'stop after mark 3 x
Next
Next
you could use this
Option Explicit
Sub main()
Dim cell As Range, nCols As Long
With ActiveSheet.UsedRange.SpecialCells(xlCellTypeBlanks)
For Each cell In .Cells
nCols = WorksheetFunction.Min(cell.Column - 1, 3)
If Intersect(cell.Offset(, -nCols).Resize(, nCols + 1), .Cells).Count < 4 Then cell.Value = "x"
Next
End With
End Sub
I have five worksheet in all that are using the below code which is stored in a workbook. The first worksheet works perfectly well with the code. The second spreadsheet can check for the first item before returning the error. The subsequent third and fourth worksheet return the error immediately. The fifth worksheet on the other hand return error 400. May I know is my code the source of the problem or it's the checkbox because I copied and paste from the first worksheet.
Sub test5()
Dim MyFile As String
Dim FinalRow As Long
Dim Row As Long
Dim i As Integer
Dim d As Integer
d = 2
i = 0
FinalRow = Cells(Rows.count, "S").End(xlUp).Row
For Row = 3 To FinalRow
If Not IsEmpty(ActiveSheet.Cells(Row, "S")) Then
i = i + 1
d = d + 1
MyFile = ActiveSheet.Cells(Row, "S").Value
If Dir(MyFile) <> "" Then
ActiveSheet.OLEObjects("CheckBox" & i). _
Object.Value = True ' <~~~~~~~~~~~~~~~~ Error occurs here
With ActiveSheet.Cells(d, "F")
.Value = Now
.NumberFormat = "dd/mm/yy"
'If (ActiveSheet.Cells(d, "F") - ActiveSheet.Cells(d, "G") >= 0) Then
' ActiveSheet.Cells(d, "F").Font.Color = vbRed
'End If
If (.Value - .Offset(0, 1).Value) >= 0 Then
.Font.Color = vbRed
Else
.Font.Color = vbBlack
End If
End With
' i = i + 1
'd = d + 1
End If
End If
Next
End Sub
The program terminates after stepping into this line of code:
ActiveSheet.OLEObjects("CheckBox" & i). _ Object.Value = True
OLEObject does not have a member called value. If you are trying to display the OLEObject, use visible instead
ActiveSheet.OLEObjects("CheckBox" & i).Visible = True
See all OLEObject members here :
OLEObject Object Members