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
Related
I am beginner at VBA, I am stuck plz help. In this image(linked at the end of paragraph), I am trying to insert line above the cells which contains different name than the name of upper cell. Plz tell me if there is an easier way to do this or how to apply the given if else condition to whole "G" Column...
Still I am adding my code below if you don't need the image...
Sub ScanColumn()
'Application.ScreenUpdating = False
Dim varRange As Range
Dim currentCell As String
Dim upperCell As String
Dim emptyCell As String
currentCell = ActiveCell.Value
bottomCell = ActiveCell.Offset(1, 0).Value
emptyCell = ""
Dim intResult As Integer
intResult = StrComp(bottomCell, currentCell)
Dim emptyResult As Integer
emptyResult = StrComp(currentCell, emptyCell)
'I want to apply below condition to whole G column in used range
If emptyResult = 0 Then
ActiveCell.Select
ElseIf intResult = 0 Then
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Offset(1).EntireRow.Insert
ActiveCell.Offset(2, 0).Select
End If
End Sub
Here you have, just call the function "evaluateColumn" and pass the parameters, as example the "trial" sub.
Function evaluateColumn(column As String, startRow As Long, wsh As Worksheet)
Dim lastRow As Long
lastRow = wsh.Range(column & wsh.Rows.Count).End(xlUp).Row
Dim i As Long: i = startRow
Do While i < lastRow
If wsh.Cells(i, column).Value <> wsh.Cells(i + 1, column).Value And wsh.Cells(i, column).Value <> "" And wsh.Cells(i + 1, column).Value <> "" Then
wsh.Range(column & i + 1).EntireRow.Insert shift:=xlShiftDown, CopyOrigin:=xlFormatFromLeftOrAbove
i = i + 1
lastRow = lastRow + 1
End If
i = i + 1
Loop
End Function
Sub trial()
evaluateColumn "G", 2, ThisWorkbook.Worksheets("Sheet2")
End Sub
As you can see from the difference between my answer and the one below, your question isn't entirely clear. My code is an event procedure. It will run automatically, as you select a cell within the used range of column G.
If the value of the selected cell is the same as the cell below it the next row's cell will be selected.
If there is a value in either of the two cells, a blank row will be inserted and that row's cell selected. (If you want another row enable the row below the insertion.)
If either of the above conditions are true, do nothing and proceed with the selection the user made.
In order to let this code work it must be installed in the code sheet of the worksheet on which you want the action. It will not work if you install it in a standard code module, like Module1.
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim TriggerRange As Range
Dim Off As Long ' offset from Target for selection
' if more than one cell is selected choose the first cell
If Target.Cells.CountLarge > 1 Then Set Target = ActiveCell
Set TriggerRange = Range(Cells(2, "G"), Cells(Rows.Count, "G").End(xlUp))
' this code will run only if a cell in this range is selected
' Debug.Print TriggerRange.Address(0, 0)
If Not Application.Intersect(Target, TriggerRange) Is Nothing Then
Application.EnableEvents = False
With Target
If .Value = .Offset(1).Value Then
Off = 1
ElseIf WorksheetFunction.CountA(.Resize(2, 1)) Then
Rows(.Row).Insert
' Off = 1 ' or -1 to change the selection
End If
.Offset(Off).Select
End With
Application.EnableEvents = True
End If
End Sub
I am running a loop that enters a formula, copies it, then goes to the next line, checks if the 2 cells to the right are empty, if they are, then do nothing. If they contain anything at all, then paste formula (word "true" in below example) from B10.
However it pastes the formula, then stops. It doesn't keep looping down until the cells to the right are empty?
Any idea's on how to fix this would be appreciated!
Sub Macro1()
Range("B10").Select
ActiveCell.Value = "TRUE"
Range("B10").Select
Selection.Copy
Range("B11").Select
Dim cell As Range
For Each cell In ActiveSheet.Range("B11:B150")
If IsEmpty(cell.Offset(0, 3).Value) = True Then
cell.Value = ""
Else: ActiveSheet.Paste
End If
Next cell
End Sub
This should do... notice that you do not need .Select
Sub Test()
Dim ws as Worksheet: Set ws = ThisworkBook.Sheets("Sheet1")
Dim myCell as Range
For Each myCell in ws.Range("B10:B150")
If myCell.Offset(,1) <> "" and myCell.offset(,2) <> "" Then
myCell = "TRUE"
End If
Next myCell
End Sub
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
I am trying to offset the active cell until a certain condition is met. What I've written is
Do While ActiveCell.Value <> Worksheets("Unit B").Range("D1").Value
ActiveCell.Offset(0, 1).Select
Loop
Can you please help me correct this ?
Giving my entire code for reference:
Private Sub CommandButton1_Click()
Dim ddsdata As Range
Dim i As Long
i = 1
Worksheets("Unit B").Select
Set ddsdata = Worksheets("Unit B").Range("E3:E35")
Worksheets("Data Sheet").Select
Worksheets("Data Sheet").Range("E1").Select
Do While ActiveCell.Offset(0, i) <> Worksheets("Unit B").Range("D1").Value
i = i + 1
Loop
ActiveCell.Offset(1, i).Select
ActiveCell.Value = ddsdata
Try below code. Avoid using Select / Activate / ActiveCell in your code. Also always refer a cell by sheetname then the cell. eg Sheet1.Range("A1") in a workbook for better results.
Private Sub CommandButton1_Click()
Dim ddsdata As Range
Dim i As Long
i = 1
Thisworkoook.Activate
Set ddsdata = Thisworkoook.Sheets("Unit B").Range("E3:E35")
Do While Worksheets("Data Sheet").Range("E1").Offset(0, i) <> Worksheets("Unit B").Range("D1").Value
i = i + 1
Loop
ActiveCell.Offset(1, i).Select
ActiveCell.Value = ddsdata
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