I want to write the current month based on a referenced cell into the current selection. This is my code but I get the error message: object variable or with block variable not set. I don't know what the problem is - anyone have a clue?
Sub SelectionMonthNames()
Dim Currentrange As Range
For i = 1 To 3
Currentrange = Selection.Address
If i = 1 Then
Currentrange.Formula = "=DATE(YEAR($B$5);MONTH($B$5);DAY($B$5))"
Else
Currentrange.Formula = "=DATE(YEAR($B$5);MONTH($B$5)+" & CStr(i - 1) & ";DAY($B$5))"
End If
Selection.Offset(0, 1).Select
Next i
End Sub
Try
Set Currentrange = Selection.Address
Instead of
Currentrange = Selection.Address
EDIT:
So, final version of your macro should look like this:
Sub SelectionMonthNames()
Dim Currentrange As Range
For i = 1 To 3
Set Currentrange = Selection
If i = 1 Then
Currentrange.Formula = "=DATE(YEAR($B$5),MONTH($B$5),DAY($B$5))"
Else
Currentrange.Formula = "=DATE(YEAR($B$5),MONTH($B$5)+" & CStr(i - 1) &",DAY($B$5))"
End If
Selection.Offset(0, 1).Select
Next i
End Sub
Related
I want to create a userform that can find the "Sales" value in column E and then input the remaining data to the same row.
Set APAC = Sheet2
APAC.Activate
Range("E18:E1888").Select
For Each D In Selection
If D.Value = "TWO.Sales.Value" Then
Exit For
End If
Next D
Rows(D.Row).Select
D.Offset(0, 2).Value = TWO.RSA.Value
D.Offset(0, 3).Value = TWO.Part.Value
D.Offset(0, 4).Value = Application.WorksheetFunction.VLookup(TWO.Part.Value, Worksheets("DataEntry").Range("T2:U70").Value, 2, False)
D.Offset(0, 5).Value = TWO.Program.Value
D.Offset(0, 6).Value = TWO.QTY.Value
Sheet2.Activate
This is my code but
run time error '91'
occurs.
I am having error on the "Rows(D.Row).select" line – Jacob 2 mins ago
That means "TWO.Sales.Value" was not found in Range("E18:E1888") and hence D was nothing. You need to check if the value was found. Also I have a feeling that you wanted If D.Value = TWO.Sales.Value Then instead of If D.Value = "TWO.Sales.Value" Then
Also there is no need to Select/Activate. You can directly work with the objects. You may want to see How to avoid using Select in Excel VBA
Whenever you are working with VLookup, it is better to handle the error that may pop up when a match is not found. There are various ways to do it. I have shown one way in the code below.
Is this what you are trying? (UNTESTED)
Option Explicit
Sub Sample()
Dim APAC As Worksheet
Dim curRow As Long
Dim aCell As Range
Dim Ret
Set APAC = Sheet2
With APAC
For Each aCell In .Range("E18:E1888")
If aCell.Value = TWO.Sales.Value Then
curRow = aCell.Row
Exit For
End If
Next aCell
If curRow = 0 Then
MsgBox "Not Found"
Else
.Range("G" & curRow).Value = TWO.RSA.Value
.Range("H" & curRow).Value = TWO.Part.Value
On Error Resume Next
Ret = Application.WorksheetFunction.VLookup(TWO.Part.Value, _
Worksheets("DataEntry").Range("T2:U70").Value, 2, False)
On Error GoTo 0
If Ret <> "" Then .Range("I" & curRow).Value = Ret
.Range("J" & curRow).Value = TWO.Program.Value
.Range("K" & curRow).Value = TWO.QTY.Value
End If
End With
End Sub
NOTE: If the range .Range("E18:E1888") is dynamic then you may want to find the last row as shown HERE and then use the range as .Range("E18:E" & LastRow)
In the code shown below, i am in the first section moving data from sheet "Ark2" to the sheet "Ark1". in the second section, i transpose from vertical to horizontal. Now i am rinning it in module, but i am getting an popup saying "16" and it is deleting data from my sheet "Ark2" and therefor also data on ark2.
it is not adding data from the first sheet to the second or horizonting the colums.
hope you can help!!
Sub MyProcedure()
a = Worksheets("ark1").Cells(Rows.Count, 1).End(xlUp).Row
MsgBox (a)
End Sub
Private Sub CommandButton1_Click()
Dim nøgletal As String, år As Integer
Worksheets("Ark2").Select
nøgletal = Range("B2")
år = Range("C2")
Worksheets("Ark1").Select
Worksheets("Ark1").Range("A4").Select
ThisWorkbook.Worksheets("Ark1").Range("C1:C100").Value = ThisWorkbook.Worksheets("Ark2").Range("C12:C100").Value
ThisWorkbook.Worksheets("Ark1").Range("D1:D100").Value = ThisWorkbook.Worksheets("Ark2").Range("D12:D100").Value
ThisWorkbook.Worksheets("Ark1").Range("E1:E100").Value = ThisWorkbook.Worksheets("Ark2").Range("M12:M100").Value
ThisWorkbook.Worksheets("Ark1").Range("F1:F100").Value = ThisWorkbook.Worksheets("Ark2").Range("N12:N100").Value
ThisWorkbook.Worksheets("Ark1").Range("G1:G100").Value = ThisWorkbook.Worksheets("Ark2").Range("O12:O100").Value
ThisWorkbook.Worksheets("Ark1").Range("A1:A16").Value = ThisWorkbook.Worksheets("Ark2").Range("A12:A16").Value
If Worksheets("Ark1").Range("A4").Offset(1, 0) <> "" Then
Worksheets("Ark1").Range("A4").End(xlDown).Select
End If
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = nøgletal
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = år
Worksheets("Ark2").Select
Worksheets("Ark2").Range("B2", "B16").Select
End Sub
Sub x()
Dim lngDataColumns As Long
Dim lngDataRows As Long
lngDataColumns = 3
lngDataRows = 4
For t = 1 To lngDataRows
Range("l2").Offset(((t - 1) * lngDataColumns) - 1, 0).Resize(lngDataColumns, 1).Value = _
Application.Transpose(Range("e1:g1").Value)
Range("M2").Offset(((t - 1) * lngDataColumns) - 1, 0).Resize(lngDataColumns, 1).Value = _
Application.Transpose(Range("e1:g1").Offset(t).Value)
Next t
End Sub
why am i getting error or popup saying “16”
Should be evident why if you add a value in say ark1!A17 and rerun:
Sub MyProcedure()
a = Worksheets("ark1").Cells(Rows.Count, 1).End(xlUp).Row
MsgBox (a)
End Sub
If not, try adding also into ark1!A18 and rerunning.
Hopefully the title is clear. I am trying to search through multiple tables on a single sheet. The information I am looking for is the same for all of the tables, just that the corresponding column is located in different spots (e.g. in one table the column I want to search is in I, while for another table it could be in O.) which makes it a bit more challenging for me.
I want to search through each column that has the same title (Load Number) and depending on its value, copy that entire row over to a sheet that corresponds with that value.
Below is what I have so far in VBA as well as a picture to hopefully clarify my issue.
Any help/advice is appreciated!
http://imgur.com/a/e9DyH
Sub Load_Number_Finder()
Dim ws As Worksheet
Dim i As Integer
Dim j As Integer
j = 1
Set ws = Sheets.Add(After:=Sheets("Master"))
ws.Name = ("Test Load " & j)
i = 1
Sheets("Master").Select
For Each cell In Sheets("Master").Range("M:M")
If cell.Value = "1" Then
j = 1
'Set WS = Sheets.Add(After:=Sheets("Master"))
'WS.Name = ("Test Load " & j)
matchRow = cell.Row
Rows(matchRow & ":" & matchRow).Select
Selection.Copy
Sheets("Test Load " & j).Select
ActiveSheet.Rows(i).Select
ActiveSheet.Paste
Sheets("Master").Select
i = i + 1
ElseIf cell.Value = "" Then
' 2, 3, 4, 5, cases
Else
' Something needs to go here to catch when it doesnt have a load number on it yet
End If
' Err_Execute:
' MsgBox "An error occurred."
Next
End Sub
Try this function. This should work for you. Let me know what the results are with your sheet. I made a mock up sheet and tested it, it worked. I can make changes if this is not exactly what you are looking for.
Option Explicit
Sub copyPaste()
Dim rowCount, row_ix, temp, i As Integer
Dim TD_COL_IX As Integer
Dim td_value As String
Dim td_values() As String
rowCount = Worksheets("Master").Cells(Rows.Count, "A").End(xlUp).Row
For row_ix = 1 To rowCount
temp = isNewTable(CInt(row_ix))
If temp > 0 Then
TD_COL_IX = temp
ElseIf TD_COL_IX > 0 Then
td_value = Worksheets("Master").Cells(row_ix, TD_COL_IX)
If Not td_value = "" Then
td_values = Split(td_value, " ")
For i = 0 To UBound(td_values)
If Not sheetExists("Test Load " & td_values(i)) Then
Sheets.Add.Name = "Test Load " & td_values(i)
End If
If Worksheets("Test Load " & td_values(i)).Cells(1, 1).Value = "" Then
Worksheets("Master").Range(Worksheets("Master").Cells(row_ix, 1), Worksheets("Master").Cells(row_ix, TD_COL_IX - 1)).Copy _
Destination:=Worksheets("Test Load " & td_values(i)).Cells(1, 1)
Else
Dim rowCount_pasteSheet As Integer
rowCount_pasteSheet = Worksheets("Test Load " & td_values(i)).Cells(Rows.Count, "A").End(xlUp).Row
Worksheets("Master").Range(Worksheets("Master").Cells(row_ix, 1), Worksheets("Master").Cells(row_ix, TD_COL_IX - 1)).Copy _
Destination:=Worksheets("Test Load " & td_values(i)).Cells(rowCount_pasteSheet + 1, 1)
End If
Next i
End If
End If
Next row_ix
End Sub
Function isNewTable(row_ix As Integer) As Integer
Dim colCount, col_ix As Integer
colCount = Worksheets("Master").Cells(row_ix, Columns.Count).End(xlToLeft).Column
For col_ix = 1 To colCount
If Not IsError(Worksheets("Master").Cells(row_ix, col_ix).Value) Then
If Worksheets("Master").Cells(row_ix, col_ix).Value = "LD #" Then
isNewTable = col_ix
Exit Function
End If
End If
Next col_ix
isNewTable = 0
End Function
' ####################################################
' sheetExists(sheetToFind As String) As Boolean
'
' Returns true if the sheet exists, False otherwise
' ####################################################
Public Function sheetExists(sheetToFind As String) As Boolean
Dim sheet As Worksheet
sheetExists = False
For Each sheet In Worksheets
If sheetToFind = sheet.Name Then
sheetExists = True
Exit Function
End If
Next sheet
End Function
I have problem with closing one userform and going to next. UserForm3 after clicking command button should be closed and UserForm4 should be shown. Unfortunately I get "Run time Error 91 object variable or with block variable not set". I've dug deep into internet and I am pretty sure that problem is with Userform4, although code for UserForm3 is highlighted as bugged. Basicly I want UserForm4 to be displayed and have all the textboxes filled with data from sheet "Log", based on choice from Combobox from UserForm3. Choice from UserForm3 is saved to cell E1 on "Log" Sheet.
Code from UserForm3
Private Sub CommandButton1_Click()
Sheets("Log").Range("E1") = ComboBox2.Text
Unload Me
UserForm4.Show <- ERROR DISPLAYED HERE
End Sub
In UserForm4 I want to find value from E1 in cells below and later on fill textboxes in Userform4 with data from the row, in which E1 value was found.
Code for UserForm4
Private Sub UserForm_Initialize()
Dim Name As String
Dim rng As Range
Dim LastRow As Long
Dim wart As Worksheet
wart = Sheets("Log").Range("E1")
LastRow = ws.Range("B3" & Rows.Count).End(xlUp).Row + 1
Name = Sheets("Log").Range("E1")
UserForm4.TextBox8.Text = Name
nazw = Application.WorksheetFunction.VLookup(wart, Sheets("Log").Range("B3:H" & LastRow), 1, False)
UserForm4.TextBox1.Text = ActiveCell.Offset(, 1)
UserForm4.TextBox2.Text = ActiveCell.Offset(, 1)
UserForm4.TextBox3.Text = ActiveCell.Offset(, 1)
UserForm4.TextBox4.Text = ActiveCell.Offset(, 1)
UserForm4.TextBox5.Text = ActiveCell.Offset(, 1)
UserForm4.ComboBox1.Text = ActiveCell.Offset(, 1)
UserForm4.TextBox6.Text = ActiveCell.Offset(, 1)
UserForm4.TextBox7.Text = ActiveCell.Offset(, 1)
End Sub
The code below is to avoid to run-time errors mentioned in the code above, it's not debugged for the VLookup function part.
Option Explicit
Private Sub UserForm_Initialize()
Dim Name As String
Dim LastRow As Long
Dim wart As Variant
Dim ws As Worksheet
Dim nazw As Long
' set ws to "Log" sheets
Set ws = Sheets("Log")
With ws
wart = .Range("E1")
' method 1: find last row in Column "B" , finds last row even if there empty rows in the middle
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
' method 2 to find last row, equivalent to Ctrl + Shift + Down
' LastRow = .Range("B3").CurrentRegion.Rows.Count + 1
' a little redundant with the line 2 above ?
Name = .Range("E1")
End With
With Me
.TextBox8.Text = Name
' ****** Need to use Match instead of Vlookup VLookup Section ******
If Not IsError(Application.Match(wart, ws.Range("B1:B" & LastRow - 1), 0)) Then
nazw = Application.Match(wart, ws.Range("B1:B" & LastRow - 1), 0)
Else ' wart record not found in range
MsgBox "Value in Sheet " & ws.Name & " in Range E1 not found in Column B !", vbInformation
Exit Sub
End If
.TextBox1.Text = ws.Range("B" & nazw).Offset(, 1)
.TextBox2.Text = ws.Range("B" & nazw).Offset(, 1)
.TextBox3.Text = ws.Range("B" & nazw).Offset(, 1)
.TextBox4.Text = ws.Range("B" & nazw).Offset(, 1)
.TextBox5.Text = ws.Range("B" & nazw).Offset(, 1)
.ComboBox1.Text = ws.Range("B" & nazw).Offset(, 1)
.TextBox6.Text = ws.Range("B" & nazw).Offset(, 1)
.TextBox7.Text = ws.Range("B" & nazw).Offset(, 1)
End With
End Sub
First off thank you very much. Over the last few months (i believe) my coding has progressed drastically. Any and all criticize is always welcome (rip me apart).
Recently I started to try to use different Subs (I dont quite understand when to use functions etc, but i figure it is good structure practice for when i figure it out.
I am hitting a Run-time 424 Error with the following bit of code in Sub ownerCHECK
Sub OccupationNORMALIZATION()
Dim infoBX As String
' initialize variables
LRow = ActiveSheet.UsedRange.Rows.Count
LCol = ActiveSheet.UsedRange.Columns.Count
STATUScounter = LRow
Do While infoBX = ""
infoBX = InputBox("Enter Occupation Column", "Occupation Column")
Loop
restaurCHECK (infoBX)
Application.ScreenUpdating = True
Application.StatusBar = ""
End Sub
-
Sub restaurCHECK(infoBX As String)
Dim RestaurantS(), RestaurantDQs() As Variant
Dim i, LRow, LCol, STATUScounter As Long
Dim rRng As Range
LRow = ActiveSheet.UsedRange.Rows.Count
LCol = ActiveSheet.UsedRange.Columns.Count
STATUScounter = LRow
RestaurantS = Array("estaur", "food", "cafe", "beverage", "waiter", "waitr", _
"waitstaff", "wait staff", "grill") 'array list of target occupations
RestaurantDQs = Array("fast", "pub", "import", "packing", "processing", "packag", _
"retired", "anufact", "distrib") ' disqualifying words for Restaurante category
Set rRng = Range(infoBX & "2:" & infoBX & LRow)
Application.ScreenUpdating = False
For Each cell In rRng
ownerCHECK (cell)
For i = LBound(RestaurantS) To UBound(RestaurantS)
If InStrRev(cell.Value, UCase(RestaurantS(i))) > 0 Then
cell.Offset(, 1) = "Restaurants"
cell.Interior.Color = 52479
End If
Debug.Print cell.Value
Next
For i = LBound(RestaurantDQs) To UBound(RestaurantDQs)
If InStrRev(cell.Value, UCase(RestaurantDQs(i))) And cell.Interior.Color = 52479 Then
cell.Interior.Color = 255
cell.Offset(, 1) = ""
End If
Next
STATUScounter = STATUScounter - 1
Application.StatusBar = "REMAINING ROWS " & STATUScounter & " tristram "
Next cell
End Sub
-
Sub ownerCHECK(str_owner As Range)
Dim owner() As Variant
owner() = Array("owner", "shareholder", "owns ")
For i = LBound(owner) To UBound(owner)
If InStrRev(str_owner, UCase(owner(i))) > 0 Then
cell.Offset(, 2) = "Owner"
End If
Next
End Sub
I can see a couple of issues in ownerCHECK():
"cell" is not defined (unless it's global)
you shouldn't use "cell" as a variable name (internal VBA property)
check validity of incoming range
.
Option Explicit
Sub ownerCHECK(ByRef rngOwner As Range)
If Not rngOwner Is Nothing Then
Dim owner() As Variant
owner() = Array("OWNER", "SHAREHOLDER", "OWNS ")
For i = LBound(owner) To UBound(owner)
If InStrRev(UCase(rngOwner), owner(i)) > 0 Then
rngOwner.Offset(, 2) = "Owner"
End If
Next
End If
End Sub