My code below is used to find cells with "Completed" value and to select a set range in that row and move it to another range.
I used the For Each command hoping that it would find every range with "Completed" and move them all once I click the macro but it only moves one at a time, is it possible to move all one after another without clicking the macro multiple times?
Any help would be appreciated, thanks in advance.
Sub Move_Characterisation()
Dim Msg As String, Ans As Variant
Msg = "Are you sure you want to move the completed pumps?"
Ans = MsgBox(Msg, vbYesNo)
Select Case Ans
Case vbYes
Dim r As Range, cell As Range, mynumber As Long, r2 As Range
Set r = Range("V15:S1000")
mynumber = 1
For Each cell In r
If cell.Value = "Completed" Then
Range("X15:AR15").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("X15:AR15").Interior.ColorIndex = xlNone
End If
If cell.Value = "Completed" Then
cell.Select
cell.Value = "Delete"
Range(ActiveCell, ActiveCell.Offset(0, -20)).Select
Selection.Copy
Range("X15").Select
ActiveSheet.Paste
Range("AR15").ClearContents
End If
If cell.Value = "Delete" Then
cell.Select
Range(ActiveCell, ActiveCell.Offset(0, -20)).Select
Selection.Delete Shift:=xlUp
End If
Next
Case vbNo
GoTo Quit:
End Select
Quit:
End Sub
Related
I would like to create a script, I got two (2) workbooks and they are kind of related, on the first one I would like to activate a sheet find and offset one cell and select all the info. and in case the cell contains a "yes" in the new one would paste "Yes" instead of all the info. in the previous workbook.
Sub test2()
Dim SingleCell As Range
Dim Listcells As Range
Application.ScreenUpdating = False
Workbooks("OLD CAD").Sheets("Contract History-Modifications").Activate
ActiveSheet.Range("B:B").Find(" CM Name/Number", MatchCase:=True).Select
Range(ActiveCell.Address).Offset(2, 0).Select
Range(ActiveCell.Address, Range(ActiveCell.Address).End(xlDown)).Select
Selection.Offset(0, 13).Select
'ActiveSheet.Range(Selection.Address)
'MsgBox (Selection.Address)
Set Listcells = Range(Selection.Address)
For Each SingleCell In Listcells
'Select Case True
' Case Is = InStr(1, (SingleCell.Value), "Yes") > 0
If InStr(1, (SingleCell.Value), "Yes") > 0 Then
Workbooks("NEW CAD").Sheets("Contract History-Modifications").Activate
ActiveSheet.Range("i:j").Find("A. Did the CM change the price of the transaction?", MatchCase:=True).Activate
Range(ActiveCell.Address).Offset(1, 0).Select
Range(ActiveCell.Address).Value = "Yes"
ActiveCell.Offset(1, 0).Select
End If
'End Select
Next SingleCell
End Sub
i have the below macro which removes values in column H when column I has a "Yes" in. is there a way to change this into an automatic VBA that runs in the background?
Sub Remove_Column_H_Values()'
' Remove_Column_H_Values Macro
'
'
Application.Goto Reference:="R7C9"
ActiveSheet.ListObjects("Table11").Range.AutoFilter Field:=8, Criteria1:= _
"<>"
Application.Goto Reference:="R7C8"
Range("H8").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Application.Goto Reference:="R7C9"
ActiveSheet.ListObjects("Table11").Range.AutoFilter Field:=8
Range("I8").Select
End Sub
You can add a button to your Sheet with this code.
Sub Remove_Column_H_Values()
Dim i As Integer
For i = 1 To 100 'depends on how long your Values go
If Yoursheet.Cells(i, 9) = "Yes" Then
Yoursheet.Cells(i, 8) = ""
End If
Next
End Sub
Automatic, after Typing Yes in column I:
(In the sheet-module)
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target.Column = 9 And UCase(Target.Value) = "YES" Then Target.Offset(, -1) = Empty
End Sub
I have the following macro made by someone else :
Sub test2()
Dim n As Integer, rng As Range
'n = InputBox("type the value of n")
Set rng = Range("a1")
rng.Select
line2:
n = InputBox("type no. of times you want to be repeated minus 1 for e.g if you wnat to be repeated 3 times type 2")
Range(rng.Offset(1, 0), rng.Offset(n, 0)).EntireRow.Insert
Range(rng, rng.End(xlToRight)).Copy
Range(rng, rng.Offset(n, 0)).PasteSpecial
Set rng = rng.Offset(n + 1, 0)
If rng = "" Then
GoTo line1
Else
GoTo line2
End If
line1:
Application.CutCopyMode = False
Range("a1").Select
MsgBox "macro over"
Stop
End Sub
I want the range selection to be dynamic i.e in the above code its hard coded to "a1" but since i want to repeat the macro again and again i want to select different starting point every time by selecting it through my mouse click.
Also when i am done with copying the cells its restarts, and i want to stop the macro once i have copied it one time . then select the new starting point select a row and then copy it x # of times
Thanks for your help in advance
The code you presented has some strange logic. Trying to change it according to your needs I changed a bit more then you asked for. I hope this is what you need, now. See some comments inside the sub, too.
Sub test2()
Dim n As Integer, rng As Range
'new section >>
On Error GoTo EH
Set rng = Application.InputBox("Select any cell/cells within range to copy", Type:=8)
'<<---
rng.Select
line2:
n = InputBox("type no. of times you want to be repeated minus 1 for e.g if you wnat to be repeated 3 times type 2")
Range(rng.Offset(1, 0), rng.Offset(n, 0)).EntireRow.Insert
Range(rng, rng.End(xlToRight)).Copy
Range(rng, rng.Offset(n, 0)).PasteSpecial
'Selection code:
Rng.offset(n,0).select
'this section is not necessary>>
'Set rng = rng.Offset(n + 1, 0)
'If rng = "" Then
'GoTo line1
'Else
'GoTo line2
'End If
line1:
Application.CutCopyMode = False
'range("a1").Select 'i don't think you need it
MsgBox "macro over"
'Stop is not neede
Exit Sub
EH:
MsgBox "Sub interrupted"
End Sub
I'm new/learning VBA. For this issue, I'm not getting a debug button when running my code, so I'm not able to find the error. The error just says '400' when I run the macro below, with no debug option after.
Sub Search_and_Copy_Discount_and_Shopper()
Dim strStartingCell As String
Dim strCustomer As String
Dim strDiscount As String
Dim strShopper As String
'store starting place
'look at column A, store value
strStartingCell = ActiveCell.Address
strCustomer = ActiveCell.Offset(0, -1).Value
'go to customer sheet
Sheets("Customer").Select
Range("A2").Select
'compare values in A to strCustomer
'if it matches, copy cells 1 and 2 to the right in values
'if no match, go down one cell and check again
Do While IsEmpty(ActiveCell.Value) = False
If ActiveCell.Value = strCustomer Then
strDiscount = ActiveCell.Offset(0, 1).Value
strShopper = ActiveCell.Offset(0, 2).Value
Exit Sub
Else
ActiveCell.Offset(1, 0).Select
End If
Loop
'go back to purchases sheet
Sheets("Purchases").Select
'copy in current cell and cell 1 to the right
Range(strStartingCell).Select
'paste strDiscount in current cell
'paste strShopper in cell 1 to the right
ActiveCell.Value = strDiscount
ActiveCell.Offset(0, 1).Value = strShopper
End Sub
Any pointers or mistakes you can identify would be greatly appreciated!
Have you tried adding:
On Error GoTo error_handler
on the first line of code and:
Exit Sub
error_handler:
MsgBox Err.Description
right before the "End Sub".
You should test if your ActiveCell is on the first column. Excel raises an error because the Offset(0, -1) won't exist.
Here is a code solution:
Sub Search_and_Copy_Discount_and_Shopper()
Dim strStartingCell As String
Dim strCustomer As String
Dim strDiscount As String
Dim strShopper As String
'store starting place
'look at column A, store value
If Acticell.Column = 1 Then
MsgBox ("You cannot pick a cell on column A")
Exit Sub
End If
strStartingCell = ActiveCell.Address
strCustomer = ActiveCell.Offset(0, -1).Value
'end of your code
I have some problems with a piece of code. I get an error when it has to select a range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim valrand As Long
If Intersect(Target, ActiveCell) = "Insert line" Then
valrand = ActiveCell.Row
If Worksheets("IR").Cells(valrand, 18).Value <> 5 Then
Sheets("Format").Select
MsgBox ("Format")
Range("A13:N13").Select 'here's the error
Selection.Copy
Sheets("IR").Select
Range("A" & valrand + 2 + Worksheets("IR").Cells(12, 18) & ":N" & valrand + 2 + Worksheets("IR").Cells(12, 18)).Select
Selection.Insert Shift:=xlDown
Range("A38:N38").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Range("A5").Select
contor = Worksheets("IR").Cells(12, 18).Value + 1
Worksheets("IR").Cells(12, 18).Value = contor
End If
End If
End Sub
Where I put the commet "here's the error" it gives me "Select method of Range class failed"
What am I doing wrong? Usually this piece of code worked before I added in the SelectionChange code block.
Thanks!
You should look at avoiding Select when using Sheet code (best to avoid it altogether, more later on this) and use something like this instead
Application.Goto Sheets("Format").Range("A13:N13")
(I had tried fully qualifying the reference but this only worked if I used
Sheets("Format").Select
Sheets("Format").Range("A13:N13").Select
which is clearly overkill)
While that solves you immediate issue you should look at consolidating your code, for example
Disabling Events so that other sheet events dont fire while your Select is running
Removing any Select statements
This is an example of what may work better (now with no sheet activation)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim lngRand As Long
Dim rng1 As Range
Set ws1 = Sheets("Format")
Set ws2 = Sheets("IR")
If Intersect(Target, ActiveCell) = "Insert line" Then
lngRand = ActiveCell.Row
If ws2.Cells(lngRand, 18).Value <> 5 Then
Application.EnableEvents = False
Set rng1 = Range("A" & lngRand + 2 + ws2.Cells(12, 18))
'extend rng1 from column A to colum N
Set rng1 = rng1.Resize(rng1.Rows.Count, 14)
ws2.Range(rng1.Address).Insert xlDown
'copy Format to IR
ws1.Range("A13:N13").Copy ws2.Range(rng1.Address)
'Update Format
ws2.Range("A38:N38").Delete Shift:=xlUp
ws2.Cells(12, 18).Value = ws2.Cells(12, 18).Value + 1
Application.EnableEvents = True
End If
End If
End Sub