I'm trying to copy selected cells to another sheet, but I'm always getting error message: Wrong number of arguments or invalid property assignment
This code checks if "Cells(i, 20)" is less or greater than "Cells (i, 4)" by 10%. If it's not, it deletes the row, if it is it should copy selected cells to another sheet starting 48 row.
Maybe someone could point out, what I'm doing wrong here? Here's how my code looks like:
Sub CopyHighLow()
Sheets("ProductionHighLow").Select
i = 2
j = 48
produced = 0
While Cells(i, 1) <> "" Or Cells(i + 1, 1) <> ""
produced = Cells(i, 20)
ordered = Cells(i, 4)
If Cells(i, 20) > Cells(i, 4) * 0.9 And Cells(i, 20) < Cells(i, 4) * 1.1 Then
Cells(i, 22).Delete Shift:=xlUp
i = i - 1
Else
Range(Cells(i, 1), Cells(i, 2), Cells(i, 3), Cells(i, 4), Cells(i, 20)).Select
Selection.Copy Destination:=Sheets("Rytinis").Range(Cells(j, 1), Cells(j, 2), Cells(j, 3), Cells(j, 4), Cells(j, 5))
j = j + 1
End If
i = i + 1
Wend
End Sub
UPDATE here is working modified version:
Sub CopyHighLow()
Sheets("ProductionHighLow").Select
i = 2
j = 48
produced = 0
While Cells(i, 1) <> "" Or Cells(i + 1, 1) <> ""
produced = Cells(i, 20)
ordered = Cells(i, 4)
If Cells(i, 20) > Cells(i, 4) * 0.9 And Cells(i, 20) < Cells(i, 4) * 1.1 Then
Cells(i, 22).Delete Shift:=xlUp
i = i - 1
Else
Set RangeUnionCopy = Union(Cells(i, 1), Cells(i, 2), Cells(i, 3), Cells(i, 4), Cells(i, 20))
Set RangeUnionPaste = Union(Cells(j, 1), Cells(j, 2), Cells(j, 3), Cells(j, 4), Cells(j, 5))
RangeUnionCopy.Copy Destination:=Sheets("Rytinis").Range(RangeUnionPaste.Address)
j = j + 1
End If
i = i + 1
Wend
End Sub
Problem Explanation
Your problem relies in this line
Range(Cells(j, 1), Cells(j, 2), Cells(j, 3), Cells(j, 4), Cells(j, 5))
The Range object cannot handle more than 2 named cells (this way). You may see it directly in the compiler.
More info at its official documentation
Approach solution:
I would use Union prior to this, like so:
Set RangeUnion = Union(Cells(i, 1), Cells(i, 2), Cells(i, 3), Cells(i, 4), Cells(i, 20))
RangeUnion.Copy Destination:=Sheets("Rytinis").Range(RangeUnion.Address)
This should work for what you are aiming for.
Corrected code using Union:
Sub CopyHighLow()
Dim i, j, produced, ordered
Sheets("ProductionHighLow").Select
i = 2
j = 48
produced = 0
While Cells(i, 1) <> "" Or Cells(i + 1, 1) <> ""
produced = Cells(i, 20)
ordered = Cells(i, 4)
If Cells(i, 20) > Cells(i, 4) * 0.9 And Cells(i, 20) < Cells(i, 4) * 1.1 Then
Cells(i, 22).Delete Shift:=xlUp
i = i - 1
Else
Union(Cells(i, 1), Cells(i, 2), Cells(i, 3), Cells(i, 4), Cells(i, 20)).Select
Selection.Copy Destination:=Sheets("Rytinis").Cells(j, 1)
j = j + 1
End If
i = i + 1
Wend
End Sub
You need to tell it what sheet it copies from.
Sub CopyHighLow()
Sheets("ProductionHighLow").Select
i = 2
j = 48
produced = 0
While Cells(i, 1) <> "" Or Cells(i + 1, 1) <> ""
produced = Cells(i, 20)
ordered = Cells(i, 4)
If Cells(i, 20) > Cells(i, 4) * 0.9 And Cells(i, 20) < Cells(i, 4) * 1.1 Then
Cells(i, 22).Delete Shift:=xlUp
i = i - 1
Else
ActiveSheet.Range(Cells(i, 1), Cells(i, 2), Cells(i, 3), Cells(i, 4), Cells(i, 20)).Select
Selection.Copy Destination:=Sheets("Rytinis").Range(Cells(j, 1), Cells(j, 2), Cells(j, 3), Cells(j, 4), Cells(j, 5))
j = j + 1
End If
i = i + 1
Wend
End Sub
Related
How do I resume to my desired code line instead of resume next.
Let's say I want to resume back to:
cells(i,1),value = Mid(cells(i,1).value,16,Len(cells(i,1))-16)
How would you code it?
Thanks !!
Sub testing()
Dim i As Integer
Dim lastrow As Integer
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To lastrow - 1
Cells(i, 1).Value = Mid(Cells(i, 1).Value, 16, Len(Cells(i, 1)) - 16)
On Error GoTo errhandler_2
Cells(i, 2).Value = Left(Cells(i, 2), Len(Cells(i, 2)) - 1)
Cells(i, 3).Value = Left(Cells(i, 3), Len(Cells(i, 3)) - 1)
Cells(i, 4).Value = Left(Cells(i, 4), Len(Cells(i, 4)) - 1)
Next
errhandler_2: Cells(i, 2).Value = "#NA"
errhandler_3: Cells(i, 3).Value = "#NA"
errhandler_4: Cells(i, 4).Value = "#NA"
Resume Next
End Sub
Sub testing()
Dim i As Integer
Dim lastrow As Integer
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To lastrow
letsdothis:
Cells(i, 1).Value = Mid(Cells(i, 1).Value, 16, Len(Cells(i, 1)) - 16)
On Error GoTo errhandler
Cells(i, 2).Value = Left(Cells(i, 2), Len(Cells(i, 2)) - 1)
Cells(i, 3).Value = Left(Cells(i, 3), Len(Cells(i, 3)) - 1)
Cells(i, 4).Value = Left(Cells(i, 4), Len(Cells(i, 4)) - 1)
Next
Exit Sub
errhandler: Cells(i, 2).Value = "#NA"
Cells(i, 3).Value = "#NA"
Cells(i, 4).Value = "#NA"
i = i + 1 'TO PREVENT TRAP IN THE LOOP
Resume letsdothis:
End Sub
I have a sample MS Excel table:
I am trying to write a VBA macro that would allow me to compare rows, the comparison is done using multiple cells(A2:E2), and the rest of the cells(F2:I2) would merge its values without comparison. I would like to be able to compare one row - cells(A2:E2) to cells(A3:E3), then cells(A2:E2) to cells(A4:E4)... when it is done comparing it would merge the duplicates - so that cells(Fx:Ix) would merge as well.
The final effect would look like this:
So far I have came up with this code, but running it crashes Excel. Any kind of advice would be much appreciated.
Thanks in advance
Sub MergeDuplicateRows()
Dim i As Long
Dim j As Long
Dim RowCount As Long
Dim sameRows As Boolean
sameRows = True
RowCount = Rows.Count
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For i = 1 To Range("B" & RowCount).End(xlUp).Row
For j = 1 To 5
If StrComp(Cells(i, j), Cells(i + 1, j), vbTextCompare) Then
sameRows = False
End If
Next j
If sameRows Then
Range(Cells(i, 1), Cells(i + 1, 1)).Merge
Range(Cells(i, 2), Cells(i + 1, 2)).Merge
Range(Cells(i, 3), Cells(i + 1, 3)).Merge
Range(Cells(i, 4), Cells(i + 1, 4)).Merge
Range(Cells(i, 5), Cells(i + 1, 5)).Merge
Range(Cells(i, 6), Cells(i + 1, 6)).Merge
Range(Cells(i, 7), Cells(i + 1, 7)).Merge
Range(Cells(i, 8), Cells(i + 1, 8)).Merge
Range(Cells(i, 9), Cells(i + 1, 9)).Merge
End If
sameRows = True
Next i
Application.DisplayAlerts = True
End Sub
Give this a shot - I had to change around some logic, change your For loop to a Do While loop, and instead of merging we're just deleting rows instead. I tested this on your sample data and it worked alright, I'm not sure how it will perform on 1500 rows, though:
Sub MergeDuplicateRows()
Dim i As Long
Dim j As Long
Dim sameRows As Boolean
Application.DisplayAlerts = False
Application.ScreenUpdating = False
i = 2
Do While Cells(i, 2).Value <> ""
For j = 1 To 5
If Cells(i, j).Value <> Cells(i + 1, j).Value Then
sameRows = False
Exit For
Else
sameRows = True
End If
Next j
If sameRows Then
If Cells(i, 6).Value = "" Then Cells(i, 6).Value = Cells(i + 1, 6).Value
If Cells(i, 7).Value = "" Then Cells(i, 7).Value = Cells(i + 1, 7).Value
If Cells(i, 8).Value = "" Then Cells(i, 8).Value = Cells(i + 1, 8).Value
If Cells(i, 9).Value = "" Then Cells(i, 9).Value = Cells(i + 1, 9).Value
Rows(i + 1).Delete
i = i - 1
End If
sameRows = False
i = i + 1
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Every week in work I have a file of around 15000 customers that I need to break up into two categories based on their names. My current code works but it loops through every row taking almost 3 minutes to run. What would be the best way to improve the speed - I'm assuming there are much more efficient methods than the lengthy if statement I've used?
Option Compare Text
Private Sub CommandButton1_Click()
Dim i As Long
Application.ScreenUpdating = False
For i = 2 To Rows.Count
If Cells(i, 33).Value = "Business" Then
Cells(i, 32).Value = "B"
ElseIf Cells(i, 33).Value = "Personal" Then
Cells(i, 32).Value = "P"
ElseIf Cells(i, 12).Value = "N" Then
Cells(i, 32).Value = "B"
ElseIf Cells(i, 12).Value = "Y" Then
Cells(i, 32).Value = "P"
ElseIf Cells(i, 20).Value = "PREMIER" Then
Cells(i, 32).Value = "P"
ElseIf InStr(1, Cells(i, 4), "LTD") <> 0 Then 'Finds each word in customer name, column D, and enters it as business customer
Cells(i, 32).Value = "B"
ElseIf InStr(1, Cells(i, 4), "LIMITED") <> 0 Then
Cells(i, 32).Value = "B"
ElseIf InStr(1, Cells(i, 4), "MANAGE") <> 0 Then
Cells(i, 32).Value = "B"
ElseIf InStr(1, Cells(i, 4), "BUSINESS") <> 0 Then
Cells(i, 32).Value = "B"
ElseIf InStr(1, Cells(i, 4), "CONSULT") <> 0 Then
Cells(i, 32).Value = "B"
ElseIf InStr(1, Cells(i, 4), "INTERNATIONAL") <> 0 Then
Cells(i, 32).Value = "B"
ElseIf InStr(1, Cells(i, 4), "T/A") <> 0 Then
Cells(i, 32).Value = "B"
ElseIf InStr(1, Cells(i, 4), "TECH") <> 0 Then
Cells(i, 32).Value = "B"
ElseIf InStr(1, Cells(i, 4), "CLUB") <> 0 Then
Cells(i, 32).Value = "B"
ElseIf InStr(1, Cells(i, 4), "OIL") <> 0 Then
Cells(i, 32).Value = "B"
ElseIf InStr(1, Cells(i, 4), "SERVICE") <> 0 Then
Cells(i, 32).Value = "B"
ElseIf InStr(1, Cells(i, 4), "SOLICITOR") <> 0 Then
Cells(i, 32).Value = "B"
ElseIf Cells(i, 4).Value = "UIT" Then
Cells(i, 32).Value = "B"
Else
Cells(i, 32).Value = ""
End If
Next i
Application.ScreenUpdating = True
End Sub
If you want to speed up the process, I'd stop using VBA, but write a formula instead.
Example: for finding if a cell equals "Business" or "N", you can use something like this:
=IF(OR(A1="Business";A2="N");"B";"P")
For finding if a cell contains "Business", you can use something like this:
=IF(FIND("Business";A1);"B";"P")
Combining all of this using the OR() worksheet function, you can get the whole thing. Obviously you'll need to drag your formula over your the entire column within your worksheet.
Try
Private Sub CommandButton1_Click()
Dim i As Long, r As Long
Dim vDB As Variant
Dim Ws As Worksheet
Dim rngDB As Range
Set Ws = ActiveSheet
Set rngDB = Ws.UsedRange
vDB = rngDB
r = UBound(vDB, 1)
For i = 2 To r
If vDB(i, 33) = "Business" Then
vDB(i, 32) = "B"
ElseIf vDB(i, 33) = "Personal" Then
vDB(i, 32) = "P"
ElseIf vDB(i, 12) = "N" Then
vDB(i, 32) = "B"
ElseIf vDB(i, 12) = "Y" Then
vDB(i, 32) = "P"
ElseIf vDB(i, 20) = "PREMIER" Then
vDB(i, 32) = "P"
ElseIf InStr(1, vDB(i, 4), "LTD") <> 0 Then 'Finds each word in customer name, column D, and enters it as business customer
vDB(i, 32) = "B"
ElseIf InStr(1, vDB(i, 4), "LIMITED") <> 0 Then
vDB(i, 32) = "B"
ElseIf InStr(1, vDB(i, 4), "MANAGE") <> 0 Then
vDB(i, 32) = "B"
ElseIf InStr(1, vDB(i, 4), "BUSINESS") <> 0 Then
vDB(i, 32) = "B"
ElseIf InStr(1, vDB(i, 4), "CONSULT") <> 0 Then
vDB(i, 32) = "B"
ElseIf InStr(1, vDB(i, 4), "INTERNATIONAL") <> 0 Then
vDB(i, 32) = "B"
ElseIf InStr(1, vDB(i, 4), "T/A") <> 0 Then
vDB(i, 32) = "B"
ElseIf InStr(1, vDB(i, 4), "TECH") <> 0 Then
vDB(i, 32) = "B"
ElseIf InStr(1, vDB(i, 4), "CLUB") <> 0 Then
vDB(i, 32) = "B"
ElseIf InStr(1, vDB(i, 4), "OIL") <> 0 Then
vDB(i, 32) = "B"
ElseIf InStr(1, vDB(i, 4), "SERVICE") <> 0 Then
vDB(i, 32) = "B"
ElseIf InStr(1, vDB(i, 4), "SOLICITOR") <> 0 Then
vDB(i, 32) = "B"
ElseIf vDB(i, 4) = "UIT" Then
vDB(i, 32) = "B"
Else
vDB(i, 32) = ""
End If
Next i
rngDB = vDB
End Sub
what would be the best way to merge similar rows (only order number letter different a4;a6;a8 and produced quantity) and sum (produced quantity e4;e6;e8) cells? This is how excel table looks
Clarification:
Here is the output I'm looking for
Rows 4;6;8 are the same except Order column (one letter added on 6 and 8) and Produced Column (different produced quantity). Rows 4,6,8 are merged and produced quantity is summed. Rows 6,8 is hidden or deleted.
Here is an example that could solve your problem:
Sub test()
i = 1
produced = 0
While Cells(i, 1) <> "" Or Cells(i + 1, 1) <> ""
If Cells(i, 1) <> "" Then
produced = Cells(i, 5)
j = 1
'second loop to add up every line with the same order, then suppress the lines
While Cells(j, 1) <> "" Or Cells(j + 1, 1) <> ""
If Left(Cells(j, 1), 7) = Left(Cells(i, 1), 7) And i <> j Then
produced = produced + Cells(j, 5)
Cells(j, 5).EntireRow.Select
Selection.Delete Shift:=xlUp
j = j - 1
End If
j = j + 1
Wend
End If
i = i + 1
Wend
Ok, here is the modified #Bitoubi code which helped me:
Sub RemoveSplitOrders()
i = 1
produced = 0
While Cells(i, 1) <> "" Or Cells(i + 1, 1) <> ""
If Cells(i, 1) <> "" Then
produced = Cells(i, 20)
j = 1
'second loop to add up every line with the same order, then suppress the lines
While Cells(j, 1) <> "" Or Cells(j + 1, 1) <> ""
If Left(Cells(j, 1), 8) = Left(Cells(i, 1), 8) Or Left(Cells(j, 1), 9) = Left(Cells(i, 1), 9) Then
If Cells(j, 2) = Cells(i, 2) And i <> j Then
produced = produced + Cells(j, 20)
Cells(i, 20).Value = produced
Range(Cells(j, 20), Cells(j + 1, 20)).EntireRow.Delete Shift:=xlUp
j = j - 1
End If
End If
j = j + 1
Wend
End If
i = i + 1
Wend
End Sub
I wrote a very quick script for VBA that takes a spread sheet and organizes it appropriately. For some reason I have just tried using it and I get a user defined error at this loop:
Dim qu As Long
For j = i To 10 Step -1
If Cells(j, 10) = "" Then
qu = j - 1
Do While Cells(qu, 10) = Cells(qu - 1, 10)
Cells(qu, 11) = 10
Cells(qu - 1, 11) = 10
qu = qu - 1
Loop
Cells(j - 1, 11) = 10
End If
Next j
The whole code looks like this:
Sub PopulateNF()
i = 10
Do While Cells(i, 2) <> ""
i = i + 1
Loop
For k = 10 To i Step 1
If Cells(k, 1) <> "" Then
Cells(k, 10) = ""
Else
If InStr(1, Cells(k, 2), "Received") Then
Cells(k, 10) = -1
ElseIf InStr(1, Cells(k, 2), "Workflow") Then
Cells(k, 10) = 0
ElseIf InStr(1, Cells(k, 2), "Forwarded") Then
Cells(k, 10) = 1
ElseIf InStr(1, Cells(k, 2), "Review Response") Then
Cells(k, 10) = 2
ElseIf InStr(1, Cells(k, 2), "Responded and Closed") Then
Cells(k, 10) = 4
ElseIf InStr(1, Cells(k, 2), "Sent") Then
Cells(k, 10) = 3
ElseIf InStr(1, Cells(k, 2), "Sent and Closed") Then
Cells(k, 10) = 3
End If
End If
Next k
Dim qu As Long
For j = i To 10 Step -1
If Cells(j, 10) = "" Then
qu = j - 1
Do While Cells(qu, 10) = Cells(qu - 1, 10)
Cells(qu, 11) = 10
Cells(qu - 1, 11) = 10
qu = qu - 1
Loop
Cells(j - 1, 11) = 10
End If
Next j
For a = i To 10 Step -1
If Cells(a, 1) <> "" Then
Cells(a, 11) = 10
End If
Next a
Const colA As Long = 11
Dim lngRow As Long
Dim lngLastRow As Long
lngLastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
lngRow = 10
Do While lngRow <= lngLastRow
If Cells(lngRow, colA) = "" Then
Cells(lngRow, 1).EntireRow.Delete
lngLastRow = lngLastRow - 1
Else: lngRow = lngRow + 1
End If
Loop
d = 10
Do While Cells(d, 2) <> ""
d = d + 1
Loop
For k = 6 To d Step 1
If Cells(k, 1) = "" Then
Cells(k, 1) = Cells(k, 6)
Cells(k, 6) = ""
Cells(k, 2) = Cells(k, 7)
Cells(k, 7) = ""
Cells(k, 3) = Cells(k - 1, 3)
Cells(k, 4) = Cells(k - 1, 4)
Cells(k, 5) = Cells(k - 1, 5)
Cells(k, 6) = Cells(k - 1, 6)
Cells(k, 7) = Cells(k - 1, 7)
Cells(k, 8) = Cells(k - 1, 8)
Cells(k, 9) = Cells(k - 1, 9)
End If
Next k
Const colAN As Long = 1
Dim lngRowN As Long
Dim lngLastRowN As Long
lngLastRowN = Cells.SpecialCells(xlCellTypeLastCell).Row
lngRowN = 9
Do While lngRowN <= lngLastRowN
If Cells(lngRowN, colAN) = "" Then
Cells(lngRowN, 1).EntireRow.Delete
lngLastRowN = lngLastRowN - 1
ElseIf InStr(1, Cells(lngRowN, colAN), "_") Then
Cells(lngRowN, 1).EntireRow.Delete
lngLastRowN = lngLastRowN - 1
Else: lngRowN = lngRowN + 1
End If
Loop
Range("a9").CurrentRegion.Sort key1:=Range("a9"), order1:=xlAscending, Header:=xlGuess
Range("D:D").NumberFormat = "mm/dd/yyyy"
Range("F:I").NumberFormat = "mm/dd/yyyy"
Range("C:I").HorizontalAlignment = xlCenter
Range("a:a").VerticalAlignment = xlTop
Range("J:K").EntireColumn.Delete
Range("A:J").Font.Color = vbBlack
MsgBox ("Reformatting Complete")
End Sub
Any help would be greatly appreciated!
Stepping through the code looks like your loop doesn't know where to end.
Basically the line:
Do While Cells(qu, 10) = Cells(qu - 1, 10)
is never false and "qu-1" eventually becomes negative.
I'm not sure if this works with the greater bulk of your code, but you could try:
Do While qu <> 1
That should close your loop while still allowing you to modify cell values within the loop.