Increase number of column and write into selected cell - vba

Good day,
I need help with a little problem. I have a macro which compares cell with range of cells. If the equal cell is not found, it will add the cell at the end of the range. My problem is with equal cell. If it finds it, I need to add 3 to column index and write "X" into this cell.
I have solution for unequal cell but i dont know how to increase column index and write into the cell.
I have this so far:
Sub Compare()
Dim i As Integer
'Comparing cell is from another workbook
Selection.Copy
Windows("zzz.xlsm").Activate
Range("A2").Select
ActiveSheet.Paste
i = 2
Do While Cells(i, 3).Value <> ""
Set FirstRange = Range("C" & i)
If FirstRange.Value = Cells(2, 1).Value Then
MsgBox "Found"
Exit Do
End If
i = i + 1
Loop
If MsgBox = True Then
'Missing code
Else
Range("A2").Select
Selection.Copy
ActiveSheet.Range("E" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
End If
End Sub
I will appreciate any advice. Thank you for your time.

Sub Compare()
Dim i As Integer
'Comparing cell is from another workbook
Selection.Copy
Windows("zzz.xlsm").Activate
Range("A2").Select
ActiveSheet.Paste
i = 2
Do While Cells(i, 3).Value <> ""
Set FirstRange = Range("C" & i)
If FirstRange.Value = Cells(2, 1).Value Then
MsgBox "Found"
Exit Do
End If
i = i + 1
Loop
If MsgBox = True Then
Cells(i, 6) = "X" 'used to be Missing code
Else
Range("A2").Select
Selection.Copy
ActiveSheet.Range("E" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
End If
End Sub

Related

"My code is not working"

I am trying to run the below code. But it is showing the error of Subscript out of range. When I tried to debug it, it is showing error in the 5 line: Range(“A1”).Select
While debugging, when I made the Sheet1 of 4th line as Sheet2, then it is not going on Sheet2.
Please help me run the code properly.
Sub excelmacro()
Application.ScreenUpdating = False
Sheets(“Sheet1”).Select
Range(“A1”).Select
Sheets(“Sheet2”).Select
Range(“A2”).Select
For i = 1 To 3
Sheets(“Sheet1”).Select
If Len(ActiveCell.Value) > 1 Then
Sheets(“Sheet1”).Select
Xname = Right(ActiveCell.Value, Len(ActiveCell.Value) - 6)
Xdesig = Right(ActiveCell.Offset(1, 0).Value, Len(ActiveCell.Offset(1, 0).Value) - 13)
Xsalary = Right(ActiveCell.Offset(2, 0).Value, Len(ActiveCell.Offset(2, 0).Value) - 8)
Sheets(“Sheet2”).Select
ActiveCell.Value = Xname
ActiveCell.Offset(0, 1).Value = Xdesig
ActiveCell.Offset(0, 2).Value = Xsalary
ActiveCell.Offset(1, 0).Select
Sheets(“Sheet1”).Select
ActiveCell.Offset(3, 0).Select
Else
i = 10
End If
i = i - 1
Next
Application.ScreenUpdating = True
End Sub
The quotation marks are oddball and create an error, but even after changing to 'normal' quoates there is a Subscript out of range error:
Instead of using Sheets, try Worksheets:
Worksheets("Sheet1").Select
To summarize my comments:
The double-quotes in the original code are oddly formatted. Use Notepad or the VBA IDE to replace them with appropriate plain text double quotes.
Be sure to declare your variables before using them if Option Explicit is turned on. Also just a good practice to follow even if it were not on.
(To be updated when I have more time this evening) Avoid making selections and usingActiveCell/ActiveSheet references.
With minor changes to your code it should look like this:
Sub excelmacro()
Dim i As Double, _
Xname As String, _
Xdesig As String, _
Xsalary As String
Application.ScreenUpdating = False
Sheets("Sheet1").Select
Range("A1").Select
Sheets("Sheet2").Select
Range("A2").Select
For i = 1 To 3
Sheets("Sheet1").Select
If Len(ActiveCell.Value) > 1 Then
Sheets("Sheet1").Select
Xname = Right(ActiveCell.Value, Len(ActiveCell.Value) - 6)
Xdesig = Right(ActiveCell.Offset(1, 0).Value, Len(ActiveCell.Offset(1, 0).Value) - 13)
Xsalary = Right(ActiveCell.Offset(2, 0).Value, Len(ActiveCell.Offset(2, 0).Value) - 8)
Sheets("Sheet2").Select
ActiveCell.Value = Xname
ActiveCell.Offset(0, 1).Value = Xdesig
ActiveCell.Offset(0, 2).Value = Xsalary
ActiveCell.Offset(1, 0).Select
Sheets("Sheet1").Select
ActiveCell.Offset(3, 0).Select
Else
i = 10
End If
i = i - 1
Next
Application.ScreenUpdating = True
End Sub
I think this is what you're trying to do:
Sub excelmacro()
Dim lastrowinSheet1 As Long
Dim cellinSheet2 As Range
Dim rCell As Range
Dim x As Long
With ThisWorkbook
'Set a reference to cell A1 on Sheet2.
Set cellinSheet2 = .Worksheets("Sheet2").Range("A1")
With .Worksheets("Sheet1")
'This will return the last row number containing data in column A.
lastrowinSheet1 = .Cells(Rows.Count, 1).End(xlUp).Row
'Now loop through each cell in column A of sheet1.
For x = 1 To lastrowinSheet1
If Len(.Cells(x, 1)) > 1 Then
cellinSheet2.Value = Right(.Cells(x, 1).Value, Len(.Cells(x, 1).Value) - 6)
cellinSheet2.Offset(, 1) = Right(.Cells(x, 1).Offset(1).Value, Len(.Cells(x, 1).Offset(1).Value) - 13)
cellinSheet2.Offset(, 2) = Right(.Cells(x, 1).Offset(2).Value, Len(.Cells(x, 1).Offset(2).Value) - 8)
Set cellinSheet2 = cellinSheet2.Offset(1)
x = x + 2
End If
Next x
End With
End With
End Sub
I tried taking apart your code - I think this is what it's doing:
Sub excelmacro1()
'Stop the screen flicker.
Application.ScreenUpdating = False
'Select cell A1 on Sheet1.
Sheets(“Sheet1”).Select
Range(“A1”).Select
'Select cell A2 on sheet 2.
Sheets(“Sheet2”).Select
Range(“A2”).Select
For i = 1 To 3
'Select Sheet1 again.
Sheets(“Sheet1”).Select
'If the length of text in the ActiveCell is greater than 1 character then
'execute the lines up to ELSE.
If Len(ActiveCell.Value) > 1 Then
'Select Sheet1 yet again.
Sheets(“Sheet1”).Select
'Hope the value in the ActiveCell isn't longer than 6 digits, or it will error out.
'Take all characters from the ActiveCell except the last 6.
Xname = Right(ActiveCell.Value, Len(ActiveCell.Value) - 6)
'Take all characters from the ActiveCell except the last 13.
Xdesig = Right(ActiveCell.Offset(1, 0).Value, Len(ActiveCell.Offset(1, 0).Value) - 13)
'Take all characters from the ActiveCell except the last 8.
Xsalary = Right(ActiveCell.Offset(2, 0).Value, Len(ActiveCell.Offset(2, 0).Value) - 8)
'Select Sheet2.
Sheets(“Sheet2”).Select
'Place the values in ActiveCell and the two columns to the right.
ActiveCell.Value = Xname
ActiveCell.Offset(0, 1).Value = Xdesig
ActiveCell.Offset(0, 2).Value = Xsalary
'Select the next row down.
ActiveCell.Offset(1, 0).Select
'Active Sheet1 again.
Sheets(“Sheet1”).Select
'Select the cell 3 rows down from the previous row.
ActiveCell.Offset(3, 0).Select
Else
'If the lengh of text in the ActiveCell is 1 character or less then set the value of i to 10.
i = 10
End If
'Remove 1 from i.
i = i - 1
Next
Application.ScreenUpdating = True
End Sub

Change value on specific column when condition is met on another column

I need help regarding the screenshot above. If possible I want a vba code that starts checking in F2 cell in row F(Unit Price) and change the adjacent values of row H and I to "01/01/2010" if the value on unit price is 0 and loop until an empty cell. Thanks in advance.
Range("F1").Select
ActiveSheet.Range("$A$1:$AI$9036").AutoFilter Field:=6, Criteria1:="0"
Range("H3").Select
ActiveCell.FormulaR1C1 = "1/1/2010"
Selection.AutoFill Destination:=Range("H3:I3"), Type:=xlFillCopy
Range("H3:I3").Select
Selection.FillDown
ActiveSheet.Range("$A$1:$AI$9036").AutoFilter Field:=6
Tried this one but the value doesnt change
Sub test()
irow = 2
Do
If (Sheets("Prices").Cells(6, 1).Value = 0) Then Cells(8, 1).Value = "01/01/2010"
irow = irow + 1
Loop Until IsEmpty(Sheets("Prices").Cells(irow, 6))
End Sub
This one works in less than 1 sec with 100,000 rows:
Option Explicit
Public Sub updateDates()
With ThisWorkbook.ActiveSheet.UsedRange
If ActiveSheet.AutoFilter Is Nothing Then .AutoFilter
.AutoFilter Field:=6, Criteria1:="0"
.Columns(8).Offset(1).Resize(.Rows.Count - 1) = "1/1/2010"
.AutoFilter
End With
End Sub
For i = 1 To 100000
With Sheets("Prices")
If .Range("F" & i).Value = "0" Then _
.Range("H" & i).Value = "01/01/2010"
End With
Next i
This one worked

How to only copy values using VBA

I need to copy values only without Formula from sheet to another. The following code does copy but only with Formula. I tried some solutions presented in this site but they give me errors.
For i = 2 To LastRow
'sheet to copy from
With Worksheets("Hoist")
'check column H value before copying
If .Cells(i, 8).Value >= -90 _
And CStr(.Cells(i, 9).Value) <> "Approved" _
And CStr(.Cells(i, 9).Value) <> "" _
And CStr(.Cells(i, 10).Value) = "" Then
'copy row to "display" sheet
.Rows(i).Copy Destination:=Worksheets("display").Range("A" & j)
j = j + 1
End If
End With
Next i
Try changing this line:
.Rows(i).Copy Destination:=Worksheets("display").Range("A" & j)
to this:
.Rows(i).Copy
Worksheets("display").Range("A" & j).PasteSpecial xlPasteValues
This however drops all formatting. To include formatting, you'll need to add another line like:
Worksheets("display").Range("A" & j).PasteSpecial xlPasteFormats
Another option is to enter a working column and use AutoFilter to avoid loops
insert a column in column A
the working column formuka is =AND(I2>-90,AND(J2<>"",J2<>"Approved"),K2="")
filter and copy the TRUE rows
delete working column A
code
Sub Recut()
Dim ws As Worksheet
Dim rng1 As Range
Set ws = Sheets("Hoist")
ws.AutoFilterMode = False
Set rng1 = Range([h2], Cells(Rows.Count, "H").End(xlUp))
ws.Columns(1).Columns.Insert
rng1.Offset(0, -8).FormulaR1C1 = "=AND(RC[8]>-90,AND(RC[9]<>"""",RC[9]<>""Approved""),RC[10]="""")"
With rng1.Offset(-1, -8).Resize(rng1.Rows.Count + 1, 1).EntireRow
.AutoFilter Field:=1, Criteria1:="TRUE"
.Copy Sheets("display").Range("A1")
Sheets("display").Columns("A").Delete
End With
ws.Columns(1).Delete
ws.AutoFilterMode = False
End Sub

How can I copy a row of data, and paste it with an offset

I'm working on a Excel 2010 Sheet that has some doctors names and their adresses, but frequently there are 2 names that are identical but have diferent adresses. On this cases I would like to copy the adress info to the same row as the first name but wit h an offset of 4 collumns. Heres the code I came up with
Sub OraganizadorEndereços()
ActiveCell.Select
If ActiveCell.Value = ActiveCell.Offset(1, 0).Value _
Then ActiveCell.Offset(1, 0).Activate: _
Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(0, 4)).Copy: _
ActiveCell.Offset(-1, 0).Select: _
ActiveCell.Offset(0, 5).Paste _
Else ActiveCell.Offset(1, 0).Select
End Sub
But I get an error on the
ActiveCell.Offset(0, 5).Paste _
Else ActiveCell.Offset(1, 0).Select
Part of the code, saying that the obeject does not accept this property/method
And remember, I started programing in VBA today, so if you can answer with an explanation, I would appreciate.
Try to rely less on activating and selecting cells - you can assign cells to a range variable to make things much easier. Also, you don't need to copy the cells (unless you also want to copy the formatting e.g. colours), use their .Value instead:
Sub OraganizadorEndereços()
Dim rngTest as Range 'Define rngTest variable as Range
Set rngTest = Activecell 'Set rngTest to be the ActiveCell
If rngTest.Value = rngTest.Offset(1, 0).Value Then
'Replace the .Value of the columns to right with the .Value of the row below
Range(rngTest.Offset(0,5), rngTest.Offset(0,8).value = Range(rngTest.Offset(1, 1), rngTest.Offset(1, 4)).Value
Else
Set rngTest = rngTest.Offset(1,0) 'Set rngTest to be the next line down
End If
End Sub
Try below code :
Sub OraganizadorEndereços()
Dim rng As Range
Dim offsetRng As Range
Set rng = ActiveCell
rng.Select
Set offsetRng = rng.Offset(1, 0)
If rng = offsetRng Then
offsetRng.Offset(0, 1).Resize(, 4).Copy offsetRng.Offset(0, 5)
rng.Offset(1, 0).Activate
Else
rng.Offset(1, 0).Select
End If
End Sub

Malformed VLookup formula when trying to use Range.Formula property

I have Excel sheets that will have data from many sources that will be grouped together so that what needs to be looked upon is above what you are looking from so there will be many VLookups on separate portions of one sheet.
Sub linkFDCfdv()
Range("A1").Select
Dim doesFDChaveDescription As Boolean
Dim isLastRowFDC As Boolean
Dim myRange As String
Dim firstFDCrow As Long
Dim lastFDCrow As Long
While Len(Selection.Value) > 0
If Selection.Value = "FDC" Then
If isLastRowFDC = False Then
firstFDCrow = ActiveCell.Row
End If
isLastRowFDC = True
ActiveCell.Offset(0, 3).range("A1").Select
If Len(Selection.Value) > 0 Then
doesFDChaveDescription = True
Else
doesFDChaveDescription = False
End If
ActiveCell.Offset(0, -3).range("A1").Select
Else
If isLastRowFDC = True Then
lastFDCrow = ActiveCell.Row - 1
End If
End If
If Selection.Value = "FDV" Then
ActiveCell.Offset(0, 10).range("A1").Select
myRange = "B" & firstFDCrow & ":D" & lastFDCrow
ActiveCell.Formula = "=VLOOKUP(R[0]C[-2]," & myRange & ",2)"
ActiveCell.Offset(0, -10).range("A1").Select
End If
ActiveCell.Offset(1, 0).range("A1").Select
Wend
End Sub
What's happening is that my macro makes the formula:
=VLOOKUP(I9,'B3':'D8',2)
If I take out the ' marks the macro works perfectly.
That is because you are using a mix of R1C1 style with A1 style. Is this what you are trying?
ActiveCell.Formula = "=VLOOKUP(" & ActiveCell.Offset(,-2).Address & _
"," & myRange & ",2)"