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
Related
I've created a userform where I have a "save" button which copies all of the values in the text and comment boxes to the workbook. I've included the code below but I'm wondering if there is a more efficient way of achieving this without using all the lines of code:
prod = Range("d4").Value - 1
Sheets("Latest").Select
ActiveCell.Offset(prod, 0).Select
ActiveCell.Value = 1
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Application.UserName
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Now()
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = age.Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = sex.Value
...
...
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = height.Value
I also have the same issue when loading the userform with pre-defined values. I literally have to have a line for every textbox that is to be populated:
Controls("age").Value = Format(Range("age"), "standard")
Controls("share").Value = Format(Range("share"), "percent")
Controls("salary").Value = Format(Range("salary"), "#,###")
...
...
Controls("share2").Value = Format(Range("share2"), "percent")
the code works but it just seems like it's unnecessarily long.
The trick is to use the same name for the cells as for the controls on the user-form.
The name-syntax should help to distinguish the names from other names on the sheet, eg. input_xxx.
This is a simplified solution which you have to adjust to your needs:
Sub showForm()
'assumption all cells/controls have name with syntax input_xxx
writeValuesToUserForm
UserForm1.Show vbModal
writeValuesToSheet
End Sub
Public Sub writeValuesToUserForm()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Latest")
Dim n As Name
For Each n In ThisWorkbook.Names
If n.Name Like "input_*" Then
UserForm1.Controls(n.Name).Value = n.RefersToRange
End If
Next
End Sub
Sub writeValuesToSheet()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Latest")
Dim n As Name
For Each n In ThisWorkbook.Names
If n.Name Like "input_*" Then
n.RefersToRange.Value = UserForm1.Controls(n.Name).Value
End If
Next
End Sub
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 trying to copy and paste values on the same row, meaning i should have copied values("B3:I3") on the same row using the for loop.
I have tried Rows("J" & (i+2) & ":J") and Offset() but it didnt work.
A3 gets a value, for example, if i enter a value of 5. The for loop should return the copied values("B3:I3") 5 times. But the return values are pasted on cells J3:Q6. I needed the return values to paste from J3:Q3, and the next record from R3:Y3 for the 2nd loop and Z3: AG3 for the 3rd loop
Appreciate everyone's advises as i am vba noob.
Added comment at main post for clarity
Private Sub AddItem()
Dim TotalItem As Variant
TotalItem = Range("A3").Value - 1
Dim i As Integer
For i = 1 To TotalItem
Range("B3:I3").Copy
Rows("J" & i + 2).PasteSpecial Paste:=xlPasteValues
Next i
Application.CutCopyMode = False
End Sub
would this help instead?
Private Sub AddItem()
Dim TotalItem As Variant
TotalItem = Range("A3").Value - 1
Dim i As Integer
For i = 1 To TotalItem
Range("J3").Activate
If i = 1 Then
Range("B3:I3").Copy
ActiveCell.PasteSpecial Paste:=xlPasteValues
Else
Range("B3:I3").Copy
ActiveCell.Offset(0, (i - 1) * 8).Activate
ActiveCell.PasteSpecial Paste:=xlPasteValues
End If
Next i
Application.CutCopyMode = False
End Sub
Sorry for not fully study the task, I hope this will do it.
Private Sub AddItem()
Dim TotalItem As Long
Dim rng As Range
With ThisWorkbook.ActiveSheet
Set rng = .Range("B3:I3")
TotalItem = ThisWorkbook.ActiveSheet.Range("A3").Value
Dim lNumberOfCells As Long
lNumberOfCells = rng.Cells.Count
Dim i As Long
For i = 1 To TotalItem
.Range("B3:I3").Offset(, i * lNumberOfCells).Value = .Range("B3:I3").Value
Next i
End With
End Sub
Copying active row of Sheet1 to Sheet2 based on cell condition (Column F="Yes") and also prevent duplication.
I tried the following
Private Sub CommandButton1_Click()
Dim CustomerName As String, Customeraddress As String, Customercity As String, Custtel As String, Custzip As String
Worksheets("sheet1").Select
CustomerName = Range("A2")
Customeraddress = Range("B2")
Customercity = Range("C2")
Custtel = Range("D2")
Custzip = Range("E2")
Worksheets("sheet2").Select
Worksheets("Sheet2").Range("B4").Select
If Worksheets("Sheet2").Range("B4").Offset(1, 0) <> "" Then
Worksheets("Sheet2").Range("B4").End(xlDown).Select
End If
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = CustomerName
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Customeraddress
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Customercity
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Custtel
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Custzip
Worksheets("Sheet1").Select
Worksheets("Sheet1").Range("C4").Select
End Sub
So now I need to know how to check if sheet1 Column F="Yes" for that particluar Customer. Then only copy from Sheet1 to Sheet2. If customer info is already present in Sheet2 then dont duplicate if the user clicks the button on sheet1 active row.
Try this code:
Private Sub CommandButton1_Click()
Dim lastrow As Long
'if value in column F not equal "YES" - do nothing and exit sub
If UCase(Range("F" & ActiveCell.Row).Value) <> "YES" Then Exit Sub
With ThisWorkbook.Worksheets("Sheet2")
lastrow = Application.Max(4, .Cells(.Rows.Count, "B").End(xlUp).Row + 1)
'if CustomerName is already in column B of sheet2 - do nothing and exit sub
If WorksheetFunction.CountIf(.Range("B1:B" & lastrow), _
Range("A" & ActiveCell.Row).Value) > 0 Then Exit Sub
.Range("B" & lastrow).Resize(, 5).Value = _
Range("A" & ActiveCell.Row).Resize(, 5).Value
End With
End Sub
And, please, read this post: How to avoid using Select/Active statements:)
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