The below code is automatically runs when a cell in a specified column changes and if it is not empty.
Sub mergeCells()
Dim num As Integer
Dim countmerged As Integer
If IsEmpty(ActiveCell.Value) Then
Exit Sub
Else
countmerged = -1
If ActiveCell.Offset(-1, 0).mergeCells Then
countmerged = ActiveCell.Offset(-1, 0).MergeArea.Cells.Count * -1
End If
num = ActiveCell.Offset(countmerged, -1).Value
If ActiveCell.Offset(countmerged, 0).Value = ActiveCell.Value Then
ActiveCell.ClearContents
ActiveCell.Offset(0, 1).ClearContents
ActiveCell.Offset(0, 37).ClearContents
ActiveCell.Offset(0, 36).ClearContents
ActiveCell.Offset(0, -1).ClearContents
ActiveCell.Offset(1, 0).EntireRow.Insert
ActiveCell.Offset(2, 0).EntireRow.Copy ActiveCell.Offset(1, 0).EntireRow
Range(ActiveCell.Offset(countmerged, 37), ActiveCell.Offset(0, 37)).Merge
Range(ActiveCell.Offset(countmerged, 36), ActiveCell.Offset(0, 36)).Merge
Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(countmerged, 1)).Merge
Range(ActiveCell.Offset(countmerged, -1), ActiveCell.Offset(0, -1)).Merge
Range(ActiveCell, ActiveCell.Offset(countmerged, 0)).Merge
ActiveCell.Offset(1, -1).Value = num + 1
ActiveCell.Offset(2, -1).Value = num + 2
Else
ActiveCell.Offset(1, 0).EntireRow.Insert
ActiveCell.Offset(2, 0).EntireRow.Copy ActiveCell.Offset(1, 0).EntireRow
Selection.Offset(1, -1).Value = num + 2
Selection.Offset(2, -1).Value = num + 3
End If
End If
End Sub
if the value is the same value with the above cell, they are being merged and another row with the same formulas is inserted. This works without problem.
But if the value is not the same as the above cell, only a row must be inserted with the same formulas but it adds rows without stopping.
I don't think you are showing us the important part of the code (that sets this one off).
I would try disabling events since the macro is likely changing a cell and seeing that a cell is changed (inserted, whatever) starting your event again.
Try adding these at the beginning and ending of your macro.
Application.EnableEvents = False
Application.EnableEvents = True
Related
The purpose of my macro is to simply take some information from one sheet and transfer it to another to prevent having to re-enter information. The code works perfectly when I run it via the VBA editor but results in in a Run-time error '1004': Applicaiton-defined or object-defined error when I try to run it via the hyperlink. I know the hyperlink is linked to the correct macro. What's going on?
Sub Insert_PCO_Row()
' Insert_PCO_Row Macro
' Inserts PCO information into COR log if COR number is entered in COR number column in "Sub Pricing" Worksheet.
Dim corNum As Range
Dim nextOpen As Range
Sheets("Sub Pricing").Select
Range("C3").Select
Set corNum = Sheet6.Range("A1:A1000")
Do Until Selection.Offset(0, -1) = ""
'Checks if COR # is entered in "Sub Pricing" tab OR if the COR # is already entered in "COR Log" tab.
If Selection.Value = "" Or Application.WorksheetFunction.CountIf(corNum, Selection.Value) > 0 = True Then
Selection.Offset(1, 0).Select
Else
Set nextOpen = Sheet6.Range("A9").End(xlDown).Offset(1, 0)
Selection.Copy
nextOpen.PasteSpecial xlPasteValues
Selection.Offset(0, 1).Copy
nextOpen.Offset(0, 1).PasteSpecial xlPasteValues
Selection.Offset(0, -2).Copy
nextOpen.Offset(0, 2).PasteSpecial xlPasteValues
Selection.Offset(0, -1).Copy
nextOpen.Offset(0, 3).PasteSpecial xlPasteValues
Selection.Offset(0, 7).Copy
nextOpen.Offset(0, 7).PasteSpecial xlPasteValues
Selection.Offset(1, 0).Select
End If
Loop
Sheets("COR Log").Select
End Sub
Try it without using .Select.
Option Explicit
Sub Insert_PCO_Row()
' Insert_PCO_Row Macro
' Inserts PCO information into COR log if COR number is entered in COR number column in "Sub Pricing" Worksheet.
Dim rw As Long, nrw As Long
With Worksheets("Sub Pricing")
For rw = 3 To .Cells(Rows.Count, 2).End(xlUp).Row
With .Cells(rw, 3)
If CBool(Len(.Value2)) And _
Not IsError(Application.Match(.Value2, sheet6.Columns(1), 0)) Then
nrw = sheet6.Cells(Rows.Count, "A").End(xlUp).Row + 1
sheet6.Cells(nrw, 1) = .Value
sheet6.Cells(nrw, 2) = .Offset(0, 1).Value
sheet6.Cells(nrw, 3) = .Offset(0, -2).Value
sheet6.Cells(nrw, 4) = .Offset(0, -1).Value
sheet6.Cells(nrw, 8) = .Offset(0, 7).Value
End If
End With
Next rw
End With
Worksheets("COR Log").Select
End Sub
Using the Range .Select method and relying on the Application.Selection and ActiveCell properties to identify the source and target of your operation is simply not reliable. In a similar vein, direct value transfer is more efficient than a Copy/PasteSpecial, Values operation and does not involve the clipboard.
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
I have this code where a msgbox pops up notifying a duplicate value.
Problem is the msgbox() does not go away on clicking ok and the code gets stuck.
Dim row As Integer
Dim counter As Integer
Range("c2").Activate
Application.ScreenUpdating = False
For counter = 0 To 688
If ActiveCell.Value = ActiveCell.Offset(1, 0).Value And ActiveCell.Offset(0, 2).Value = ActiveCell.Offset(1, 2).Value And ActiveCell.Offset(0, 3).Value = ActiveCell.Offset(1, 3).Value And ActiveCell.Offset(0, 9).Value = ActiveCell.Offset(1, 9).Value Then
MsgBox ("Found a duplicate")
Else ActiveCell.Offset(1, 0).Activate
End If
Next counter
The problem is that when the If is True the MsgBox is displayed and ActiveCell is never incremented. Therefore the MsgBox gets re-displayed 687 times!
I have to put jobs from one spreadsheet onto another in their priority order. If a job is listed as completed, then I do not transfer that job over. Below is my code for the top priority, "priority 1". The cell that states it's completion status sometimes has a date before or after it, which is why I put the "*" character.
Do Until IsEmpty(ActiveCell) Or count > 14
If ActiveCell.Value = "Priority I" Then
ActiveCell.Offset(0, 6).Select
If ActiveCell.value = "completed" like "*completed*" Then
ActiveCell.Offset(1, -6).Select
Else
ActiveCell.Offset(0, -1).Select
word0 = ActiveCell.Value
ActiveWindow.ActivateNext
ActiveCell = word0
ActiveWindow.ActivateNext
ActiveCell.Offset(0, -9).Select
word = Left(ActiveCell.Value, 6)
ThisWorkbook.Activate
ActiveCell.Offset(0, 1).Select
ActiveCell = word
ActiveWindow.ActivateNext
ActiveCell.Offset(0, 1).Select
word1 = ActiveCell.Value
ThisWorkbook.Activate
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = word1
ActiveWindow.ActivateNext
ActiveCell.Offset(0, 1).Select
word2 = ActiveCell.Value
ThisWorkbook.Activate
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = word2
ActiveWindow.ActivateNext
ActiveCell.Offset(0, 1).Select
word3 = ActiveCell.Value
ThisWorkbook.Activate
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = word3
ActiveCell.Offset(1, -4).Select
ActiveWindow.ActivateNext
ActiveCell.Offset(1, 1).Select
count = count + 1
End If
Else
ActiveCell.Offset(1, 0).Select
End If
Loop
I have confirmed that it is checking the correct column, it just doesn't catch the word completed. So the problem resides within that line, line 4.
Change
If ActiveCell.value = "completed" like "*completed*" Then
to
If Instr(1, UCase(ActiveCell.Value), "COMPLETED") > 0 Then
or
If UCase(ActiveCell.Value) like "*COMPLETED*" Then
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