I am trying to automate repetitive tasks by using .inputboxes in Excel.
Note: CopyAmt is an integer returned from another InputBox, userInputRange is type 8 box, and RowCnt is the Row.Count of userInputRange.
For i = 1 To CopyAmt
userInputRange.Copy
ActiveCell.Offset(RowCnt, 0).Activate
ActiveCell.PasteSpecial
ActiveSheet.Range(ActiveCell.Offset(, 24), ActiveCell.Offset(RowCnt - 1, 24)).Value = Application.InputBox(Prompt:="Internal Value", Type:=2)
Next i
If a user was to click Cancel, I would want to exit the sub only after deleting the selection that was just pasted on line 4 of the above code. This is what I was trying.
For i = 1 To CopyAmt
userInputRange.Copy
ActiveCell.Offset(RowCnt, 0).Activate
ActiveCell.PasteSpecial
ActiveSheet.Range(ActiveCell.Offset(, 24), ActiveCell.Offset(RowCnt - 1, 24)).Value = Application.InputBox(Prompt:="Internal Value", Type:=2)
If ActiveSheet.Range(ActiveCell.Offset(, 24), ActiveCell.Offset(RowCnt - 1, 24)).Value = False Then
Selection.Delete
Exit Sub
End If
Next i
This results in a mistype and I would love some clarification on the things I am doing wrong, or just not efficiently.
Thank you for your time.
Sean,
Give this a try. Note: this is untested code but should work.
For i = 1 To CopyAmt
userInputRange.Copy
ActiveCell.Offset(RowCnt, 0).Activate '*** Changes ActiveCell!
With ActiveCell '*** Use With block to simplify code
.PasteSpecial
Temp = Application.InputBox(Prompt:="Internal Value")
If (Temp <> False) Then
ActiveSheet.Range(.Offset(, 24), .Offset(RowCnt - 1, 24)).Value = Temp
Else
.ClearContents '*** You don't want to delete the cell just clear the value.
Return '*** Get me out of the Subroutine
End If
End With
Next i
Edited: Removed the Type=2 from the Application.InputBox line.
You can test for the type of data your need in the latter code.
Related
I am attempting to build a loop that will look at each row in a column of data and split based on the first instance of an " ". I can get this to work on one line but the loop never activates. I tried my best at formatting this code but could not find a tutorial on how to have the commands appear as different colors and whatnot.
Dim num
Dim RowCnt As Integer
Dim x As Integer
ActiveCell.Select ' the cell to split
RowCnt = Range(Selection, Selection.End(xlDown)).Rows.Count 'determines #rows in column to split
With ActiveCell ' with block
For x = 1 To RowCnt ' define # loops
.Offset(, -1).FormulaR1C1 = "=FIND("" "",RC[1],1)" ' determine first " "
num = .Offset(, -1).Value ' assign the number of chars to 'num'
Selection.TextToColumns Destination:=ActiveCell, DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(num, 1)), TrailingMinusNumbers:=True ' splits once based on 'num'
.Offset(, -1).ClearContents ' clear
.Offset(1, 0).Activate
Next x
End With
End Sub
I was able to cheat the answer. The issue is the Text to Columns always referred to the first cell until the sub ended. My solution was to make the looped code its own sub and call it in a separate subs loop. That way it ends the sub each time before being called again.
Use this code instead (tested: works!)
Sub updated_delimitter()
start_cell = ActiveCell.AddressLocal
n = Range(start_cell, Range(start_cell).End(xlDown)).Rows.Count 'determines #rows in column to split
Application.ScreenUpdating = False
For x = 0 To n - 1 ' define # loops
this_cell = Range(start_cell).Offset(x).AddressLocal
Range(this_cell).Select
word_ = Range(this_cell).Value
split_at = InStr(word_, " ")
Range(this_cell).TextToColumns Destination:=Range(this_cell), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(split_at, 1)), TrailingMinusNumbers:=True ' splits once based on 'num'
Next
Application.ScreenUpdating = True
End Sub
original code had issues with referencing in relation to 'activecell' which you referenced in the text-to-columns section - removed the with statement and no need to insert num when you can simply store it within VB (getting rid of its placements also mean no code required to remove it...
You could achieve the same in 3 lines of code♦ (w/ for loop) using the following:
Sub test2()
'Range("d2").Select
With Selection
.Offset(, 3).Formula2R1C1 = _
"=LET(x_,RC[-3]:OFFSET(RC[-3],MATCH(0,IFERROR(SEARCH("""",RC[-3]:OFFSET(RC[-3],ROWS(C[-3])-ROWS(RC[-3])-1,0)),0),0)-1,0),IF(ISODD(SEQUENCE(1,2,1,1)),MID(x_,1,IFERROR(SEARCH("" "",x_)-1,LEN(x_))),IF(ISERROR(SEARCH("" "",x_)),"""",MID(x_,SEARCH("" "",x_)+2,LEN(x_)))))"
Range(.AddressLocal, .End(xlDown).Offset(, 1)).Value = Range(Replace(.Offset(, 3).AddressLocal, "$", "") & "#").Value
.Offset(, 3).ClearContents
End With
End Sub
This uses the function:
=LET(x_,D2:OFFSET(D2,MATCH(0,IFERROR(SEARCH("",D2:OFFSET(D2,ROWS(D:D)-ROWS(D2)-1,0)),0),0)-1,0),IF(ISODD(SEQUENCE(1,2,1,1)),MID(x_,1,IFERROR(SEARCH(" ",x_)-1,LEN(x_))),IF(ISERROR(SEARCH(" ",x_)),"",MID(x_,SEARCH(" ",x_)+2,LEN(x_)))))
... which is an array function that reproduces the original list with relevant cells split as req.
REVISED
Here for sample file (requires Microsoft Onedrive a/c - read only file avail.)
♦ Office 365 compatibility; '3 lines' ignoring with/end/sub/etc.
ta 💪
I'm trying to write a code that will copy data over from one worksheet into another, I keep getting an error specifically on the line where I implement my For loop, the error says "Application-defined or object-defined error", any help would be greatly appreciated.
Global qty As Variant
***********
Sub PartOrder()
qty = Application.InputBox("How many assemblies are needed?")
Sheets.Add After:=Worksheets(Sheets.Count)
PartOrderForm.Show
End Sub
If CheckBox1.Value = True Then
ActiveSheet.Range("A1") = "Part Number"
ActiveSheet.Range("B1") = "Part Name"
ActiveSheet.Range("C1") = "Number of Parts Needed"
Range("A2").Activate
For i = 2 To 8
ActiveSheet.Cells(i - 1, 1) = Worksheets("F8X SUSPENSION LINKS REV2").Cells(8 - i, 2)
Next i
Else: End If
End Sub
When the counter reaches 8, you are referring to 8-i row, which turns out to be 0 resulting in the error.
Seems like an off by one error
This part of your code Cells(8 - i, 2), goes to Cell 0. And in excel, it the cell index needs to start with 1
I would have a question regarding VisualBasics for Application (VBA) in Excel.
I need to include two buttons on my worksheet(add and delete).
When pressing the add button a new block of values should be added below one existing block, separated by a blank row.
When pressing the delete button the a block should become deleted.
-> see pictures
My current state is the following one.
Copy and paste works, but only for one single line not for multiple lines
Sub AddLibs()
Dim r As ListObject
Dim c As Integer
ActiveSheet.Unprotect "test"
ActiveSheet.ListObjects("data").ListRows(ActiveCell.Row).Range.Select
Set r = ActiveSheet.ListObjects("data")
c = r.Range.Rows.Count
ActiveSheet.ListObjects("data").Resize Range("A1:B" & c)
Selection.Copy
Selection.Insert Shift:=xlToDown, CopyOrigin:=xlFormatFromRightorAbove
Application.CutCopyMode = False
ActiveSheet.Protect "test", True, True
End Sub
I found an appropriate solution.
Implementation looks like this
Adding a block
Sub AddLibs()
If Cells(Selection.Row, 1).Value = "name" Then
ActiveSheet.Unprotect "test"
For counter = 0 To 3
ActiveCell.Offset(counter + 4, 0).EntireRow.Insert
ActiveCell.Offset(counter + 4, -1).Value = ActiveCell.Offset(counter, -1)
Next counter
ActiveSheet.Protect "test", True, True
Else
MsgBox "Please klick into a library Cell to add a new one!", , "Not possible action"
End If
End Sub
deleting a block
Sub DeleteLibs()
If Cells(Selection.Row, 1).Value = "name" Then
ActiveSheet.Unprotect "test"
For counter = 3 To 0 Step -1
ActiveCell.Offset(counter, 0).EntireRow.Delete
Next counter
ActiveSheet.Protect "test", True, True
Else
MsgBox "Please klick into the library Cell and push button again to delete!", , "Not possible action"
End If
End Sub
Why are you copy-pasting?
I have just put three values in A1, A2 and A3, and I have run this piece of code:
Range("B1:B3").Value = Range("A1:A3").Value
The values from A1:A3 have been copied to B1:B3. As you see, there's a very easy way to copy ranges without using the clipboard (.Copy, .Paste).
Updated and Edited
I am new to this whole world, but here is my issue as it stands:
As the userform initializes the below code applies a filter to my 'clean import', copies column a into a temp sheet, which is what the listbox uses to populate itself.
Set ws = ThisWorkbook.Worksheets("Clean_Import")
ws.Activate
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
ws.Range("A1:K1000").AutoFilter Field:=5, Criteria1:="<1"
Range("A:A").Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("TempSheet").Select
Columns("A:A").Select
Range("A2").Activate
ActiveSheet.Paste
ODList1.List = Sheets("TempSheet").Range("A2:A100").Value
End Sub
From then in it is just double clicking on the list box to lookup the selected items and vlook some data into text boxes.
With Me.ODList1
For i = 0 To .ListCount - 1
If .Selected(i) Then
TextBox11.Value = Application.VLookup(.List(i, 0), Sheet3.Range("A1:K100"), 3)
TextBox12.Value = Format(Application.VLookup(.List(i, 0), Sheet3.Range("A1:K100"), 7), "dd / mm / yyyy")
TextBox13.Value = Application.VLookup(.List(i, 0), Sheet3.Range("A1:K100"), 10)
Exit For
End If
Next
End With
This code works in all but one of my scenarios. I realise now if i select the list box item that happens to be the first line in the range OR the last in the range in my 'clean import' then I get the following error.
Run-Time error '-2147352571 (80020005)': Could not set the value
property. Type mismatch.
The only thing I can think is that the value doesn't match, but that doesn't seem possible as the list box is populated from a direct copy from the range it is vlooking through
I look forward to hearing your thoughts,
Cheers,
Bill
That is happening because the Vlookup is not able to find a match. Here is a simple way to reproduce the error
Private Sub CommandButton1_Click()
TextBox1.Value = Application.VLookup("Sid", Sheet1.Range("A1:K100"), 3)
End Sub
To handle this, you need to introduce proper error handling. Here is an example
Dim Ret As Variant
Ret = Application.VLookup("Sid", Sheet1.Range("A1:K100"), 3)
If IsError(Ret) Then
TextBox1.Value = "Error"
Else
TextBox1.Value = Ret
End If
I made some small adjustments to the way I brought the data in and problem went away.
Not really sure where the issue was creeping in. But it crept back out again.
Every time I try to run my macro, the first section surrounded by the LIRCounter runs just fine, but Excel returns a "Run-time error '1004': Application-defined or object-defined error" and the Debug highlights my Range(...).Merge sections on the rest of my macro.
I have tried reformatting the range by removing the .Merge, the Counter variable, and rewriting my entire code, but I can't narrow down what part of the range is causing the error.
I have tried reformatting the range by removing the .Merge, the Counter variable, and rewriting my entire code, but I can't narrow down what part of the range is causing the error.
Sub MergeCells()
Set Worksheet = Worksheets("Technical Data")
With Worksheet
For LIRCounter = 44 To 15 Step -1
If .Cells(LIRCounter, 19).Value = Not IsEmpty(Cells(LIRCounter, 19)) Then
Else
.Range(.Cells(LIRCounter, 21), .Cells(LIRCounter, 26)).Merge
End If
If .Cells(LIRCounter, 19).Value = Not IsEmpty(Cells(LIRCounter, 19)) Then
Else
.Range(.Cells(LIRCounter, 21), .Cells(LIRCounter, 26)) = "N/A"
End If
Next LIRCounter
For ETCounter = 44 To 15 Step -1
If .Cells(ETCounter, 3).Value = "Structural" Then
.Range(.Cells(ETCounter, 4), .Cells(ETCounter, 12)).Merge
End If
If .Cells(ETCounter, 3).Value = "Structural" Then
.Range(.Cells(ETCounter, 4), .Cells(ETCounter, 12)) = "N/A - Structural"
End If
Next ETCounter
For ETCounter2 = 44 To 15 Step -1
If .Cells(ETCounter2, 3).Value = "Structural" Then
.Range(.Cells(ETCounter2, 15), .Cells(ETCounter2, 26)).Merge
End If
If .Cells(ETCounter2, 3).Value = "Structural" Then
.Range(.Cells(ETCounter2, 15), .Cells(ETCounter2, 26)) = "N/A - Structural"
End If
Next ETCounter2
End With
End Sub
The expected result is if "Structural" is selected from the dropdown menu in cell C15, then the cells D15:L15 merge into one cell, and the cells O15:Z15 merge into one cell, and both merged cells say "N/A - Structural". And the same goes for every row down to row 44. When the Macro is run, it just returns "Run-time error '1004': Application-defined or object-defined error" and no cells are merged.
How it is supposed to work
As a suggestion you could write the code simpler, remove a lot of redundant code. Just one for loop because all three loops are the same and just two if else. Why the error? It is not reproducible to me. Try to comment most of the code out and try to narrow down the source of the error. The source of the error could be the data in the sheet as well, so try to run the code in empty/dummy sheet first. HTH.
Option Explicit
Sub MergeCells()
Dim TechnicalDataSheet As Worksheet
Dim counter As Long
Set TechnicalDataSheet = Worksheets("Technical Data")
With TechnicalDataSheet
For counter = 44 To 15 Step -1
If .Cells(counter, 19).Value = "" Then
.Range(.Cells(counter, 21), .Cells(counter, 26)).Merge
.Range(.Cells(counter, 21), .Cells(counter, 26)) = "N/A"
End If
If .Cells(counter, 3).Value = "Structural" Then
.Range(.Cells(counter, 4), .Cells(counter, 12)).Merge
.Range(.Cells(counter, 4), .Cells(counter, 12)) = "N/A - Structural"
.Range(.Cells(counter, 15), .Cells(counter, 26)).Merge
.Range(.Cells(counter, 15), .Cells(counter, 26)) = "N/A - Structural"
End If
Next counter
End With
End Sub