I'm attempting to combine 2 rows on my excel spreadsheet into 1 row based on a particular condition being true.
I would like for my vba code to determine whether or not the string of characters in row 2 = the string of characters in row 3.
If they are equal, I would like to copy all of row 3 to column Q in row and then continue on comparing the string values of rows 3 and 4, 4 and 5, etc to the last used row of the spreadsheet.
I've attempted to modify code I've found on Stack Overflow but still can't get my macro to run. Any help with this would be greatly appreciated.
Here's a link to a similar situation I found in Stack Overflow while I was researching how to create my VBA code but I couldn't get the sample code to work for me. Not sure why. vba - excel - if value = next row value then copy another value
Here's part of the Excel worksheet I'm working with. I did have to modify the information on the spreadsheet so that it wouldn't be too wide to paste.
Member Data spreadsheet
Something like:
Public Sub ArrangeData()
Dim i As Long, unionRng As Range, lastRow As Long, counter As Long
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Data") 'change as appropriate
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("A1:G" & lastRow).Sort Key1:=.Range("G2:G" & lastRow), Order1:=xlAscending, Header:=xlYes ' 'Sort to ensure in order (and blanks will be at end
For i = 3 To .Range("G1").End(xlDown).Row + 1
If .Cells(i, "G") = .Cells(i - 1, "G") Then
counter = counter + 1
.Cells(i, "A").Resize(1, 6).Copy .Cells(i - counter, .Cells(i - counter, .Columns.Count).End(xlToLeft).Column + 1)
Else
counter = 0
End If
Next i
For i = 3 To .Range("G1").End(xlDown).Row + 1
If IsEmpty(.Cells(i, "H")) Then
If Not unionRng Is Nothing Then
Set unionRng = Union(unionRng, .Cells(i, "H"))
Else
Set unionRng = .Cells(i, "H")
End If
End If
Next i
If Not unionRng Is Nothing Then unionRng.EntireRow.Delete
End With
Application.ScreenUpdating = True
End Sub
Before:
After:
Related
i am looking for a solution to my problem. The task is to compare two consecutive rows with each other,in the range from column D1 to the last written cell in Column D. If the value of a consecutive cell is equal to the value of the previous cell , i.e. D2=D1, the macro can go next, else it shall insert a new row between the two values. Since i am fairly new to vba and mostly use information based on online research, i could not find a fitting solution til now. Below you can see a part of what tried.
Sub Macro()
'check rows
Dim a As Long
Dim b As Long, c As Long
a = Cells(Rows.Count, "D").End(xlUp).Row
For b = a To 2 Step -1
c = b - 1
If Cells(b, 4).Value = Cells(c, 4).Value Then
If Cells(b, 4).Value <> Cells(c, 4).Value Then
Rows("c").Select
Selection.Insert Shift:=xlDown
End If
End If
Next b
End Sub
Sub InsertRows()
Dim cl As Range
With ActiveSheet
Set cl = .Cells(.Rows.Count, "D").End(xlUp)
Do Until cl.Row < 2
Set cl = cl.Offset(-1)
If cl.Value <> cl.Offset(1).Value Then cl.Offset(1).EntireRow.Insert
Loop
End With
End Sub
Side note. You can benefit from reading How to avoid using Select in Excel VBA
I am trying to delete an entire row if the values in row i column 2 and row i column 3 are empty. My for loop only iterates once. Any idea why?
Sub DeleteEm()
RowCount = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To RowCount
If IsEmpty(Cells(i, 2).Value) = True And IsEmpty(Cells(i, 3).Value) = True Then
Rows(i).EntireRow.Delete
End If
Next i
End Sub
Thank you!
You have made an error which is very common for newbies in VBA. To correct the error you need to change
For i = 2 To RowCount
to
For i = RowCount to 2 Step -1
Your original code is deleting rows within the range over which you are iterating.
Consider what happens when i=4 and you delete the row corresponding to that i. Row 4 is deleted. What was row 5 now becomes row 4 BUT at the Next, i becomes 5 so i is now pointing at what was row 6 in your starting range having skipped over what was previously row 5, because that became row 4.
If you use F8 to step through your code whilst watching your sheet you will see it all happen before your eyes.
Delete Rows With Empty Cells in Two Columns
You could also consider using Application.Union to 'collect' the row ranges in a range and then delete the range in one go.
The Code
Option Explicit
Sub DeleteEm()
RowCount = Cells(Rows.Count, "A").End(xlUp).Row
Dim rng As Range
For i = 2 To RowCount
' Considering 'blank cells = empty cells + ""-cells'.
' Either (For empty cells)...
If IsEmpty(Cells(i, 2)) And IsEmpty(Cells(i, 3)) Then
' ...or (for blank cells)
'If Len(Cells(i, 2)) = 0 And Len(Cells(i, 3)) = 0 Then
If rng Is Nothing Then
Set rng = Rows(i)
Else
Set rng = Union(rng, Rows(i))
End If
End If
Next i
If Not rng Is Nothing Then
rng.Delete
End If
End Sub
Below is my source table
Name Sales
---------------------------------
Thomas 100
Jay 200
Thomas 100
Mathew 50
Output I need is as below
Name Sales
---------------------------------
Thomas 200
Jay 200
Mathew 50
Basically, I have 2 columns that can have duplicates and I need to aggregate the second column based on first column.
Current code I have is as below. Its working perfectly fine. It takes around 45 seconds to run for 4500 records. I was wondering if there is a more efficient way to do this... as it seems to be a trivial requirement.
'Combine duplicate rows and sum values
Dim Rng As Range
Dim LngRow As Long, i As Long
LngLastRow = lRow 'The last row is calculated somewhere above...
'Initializing the first row
i = 1
'Looping until blank cell is encountered in first column
While Not Cells(i, 1).Value = ""
'Initializing range object
Set Rng = Cells(i, 1)
'Looping from last row to specified first row
For LngRow = LngLastRow To (i + 1) Step -1
'Checking whether value in the cell is equal to specified cell
If Cells(LngRow, 1).Value = Rng.Value Then
Rng.Offset(0, 1).Value = Rng.Offset(0, 1).Value + Cells(LngRow, 2).Value
Rows(LngRow).Delete
End If
Next LngRow
i = i + 1
Wend
Note that this is part of a larger excel app and hence I definitely need the solution to be in Excel VBA.
Here you go:
Option Explicit
Sub Consolidate()
Dim arrData As Variant
Dim i As Long
Dim Sales As New Scripting.Dictionary 'You will need the library Microsoft Scripting Runtime
Application.ScreenUpdating = False 'speed up the code since excel won't show you what is happening
'First of all, working on arrays always speeds up a lot the code because you are working on memory
'instead of working with the sheets
With ThisWorkbook.Sheets("YourSheet") 'change this
i = .Cells(.Rows.Count, 1).End(xlUp).Row 'last row on column A
arrData = .Range("A2", .Cells(i, 2)).Value 'here im assuming your row 1 has headers and we are storing the data into an array
End With
'Then we create a dictionary with the data
For i = 1 To UBound(arrData) 'from row 2 to the last on Q1 (the highest)
If Not Sales.Exists(arrData(i, 1)) Then
Sales.Add arrData(i, 1), arrData(i, 2) 'We add the worker(Key) with his sales(Item)
Else
Sales(arrData(i, 1)) = Sales(arrData(i, 1)) + arrData(i, 2) 'if the worker already exists, sum his sales
End If
Next i
'Now you have all the workers just once
'If you want to delete column A and B and just leave the consolidate data:
With ThisWorkbook.Sheets("YourSheet") 'change this
i = .Cells(.Rows.Count, 1).End(xlUp).Row 'last row on column A
.Range("A2:B" & i).ClearContents
.Cells(2, 1).Resize(Sales.Count) = Application.Transpose(Sales.Keys) 'workers
.Cells(2, 2).Resize(Sales.Count) = Application.Transpose(Sales.Items) 'Their sales
End With
Application.ScreenUpdating = True 'return excel to normal
End Sub
To learn everything about dictionaries (and more) check this
With data in cols A and B like:
Running this short macro:
Sub KopyII()
Dim cell As Range, N As Long
Columns("A:A").Copy Range("C1")
ActiveSheet.Range("C:C").RemoveDuplicates Columns:=1, Header:=xlNo
N = Cells(Rows.Count, "C").End(xlUp).Row
Range("B1").Copy Range("D1")
Range("D2:D" & N).Formula = "=SUMPRODUCT(--(A:A= C2),(B:B))"
End Sub
will produce this in cols C and D:
NOTE:
This relies on Excel's builtin RemoveDuplicates feature.
EDIT#1:
As chris neilsen points out, this function should be a bit quicker to evaluate:
Sub KopyIII()
Dim cell As Range, N As Long, A As Range, C As Range
Set A = Range("A:A")
Set C = Range("C:C")
A.Copy C
C.RemoveDuplicates Columns:=1, Header:=xlNo
N = Cells(Rows.Count, "C").End(xlUp).Row
Range("B1").Copy Range("D1") ' the header
Range("D2:D" & N).Formula = "=SUMIFS(B:B,A:A,C2)"
End Sub
I currently have a VBScript that takes in an Excel document and re-formats it into another Excel document that's more organized.
This code must also look at the values of the CATALOG column ("B1") and place it in the Drawings column ("M1") ONLY if the beginning of the value starts with "EDASM", "EDBSM" etc., yet the "ED" prefix must be eliminated when it's moved.
For example, Catalog number EDF12-01114 would result in nothing being placed in the drawings column, but with EDSM10265, we would need SM10265 to be placed in the drawings column (drop the "ED").
All I've got so far is this, which isn't even complete:
Set objRange = objWorkSheet.Range("M1").EntireColumn
IF
objWorkSheet.Range("B1").Row = "EDF*" THEN 'Maybe correct-ish? Not sure about syntax
objRange = Null
Else
objRange = ("B1") 'Totally an awful guess, but I have no clue what to put here
End If
I've seen similar code that has loops and whatnot, but none of them seem to be doing what I need to be done. Thank you!
EDIT: Current code based off of BruceWayne's. Still doesn't return anything in Excel datasheet's Drawing column, but it looks like it's closer...
Sub move_Text()
Dim lastRow, nextRow, cel , rng
lastRow = Cells(Rows.Count, 2).End(xlUp).Row ' Since your Col. B is the data, let's find that column's last row
Set rng = Range(Cells(1, 2), Cells(lastRow, 2))
nextRow = 1
For Each cel In rng
If Left(cel.Value, 3) <> "EDF" Then
Cells(nextRow, 13).Value = Mid(cel.Value, 3, Len(cel.Value) - 2)
nextRow = nextRow + 1
End If
Next
End Sub
Another edit!
Catalog column is now "C", not "B". Also, I have two header rows, so the first catalog number is located in "C3".
Thanks again! We're getting closer.
Here's the Google Drive files: https://drive.google.com/folderview?id=0B2MeeQ3BKptFYnZfQWpwbTJxMm8&usp=sharing
IMPORTANT TO REMEMBER
In the Google Drive files: TestScript.vbs is the file where all the code is. When the script is run, select ExcelImport. That should return FinalDocument
I guess this is what you are looking for:
Sub move_Text()
Dim lastRow, nextRow, cel, rng
'get last row with data in Column B
lastRow = Cells(Rows.Count, "B").End(xlUp).Row
'set your range starting from Cell B2
Set rng = Range("B2:B" & lastRow)
'loop through all the cells in the range to check for "EDF" and "ED"
For Each cel In rng
'below condition is to check if the string starts with "EDF"
If cel.Value Like "EDF*" Then
'do nothing
'below condition is to check if the string starts with "ED"
ElseIf cel.Value Like "ED*" Then
'drop first two characters of cell's value and write in Column M
cel.Offset(0, 11).Value = Right(cel.Value, Len(cel.Value) - 2)
'else condition will be executed when none of the above two conditions are satisfied
'else condition is based on the link mentioned in your question that will handle words like "ELECTRICAL BOX"
Else
'write cell's value in Column Q
cel.Offset(0, 11).Value = cel.Value
End If
Next
End Sub
EDIT : For VBScirpt
________________________________________________________________________________
Sub Demo()
Dim lastRow, nextRow, cel, rng
Const xlShiftToRight = -4161
Const xlUp = -4162
Const xlValues = -4163
Const xlWhole = 1
Const xlPrevious = 2
With objWorksheet
'get last row with data in Column B
lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
'set your range starting from Cell B2
Set rng = .Range("C2:C" & lastRow)
End With
'loop through all the cells in the range to check for "EDF" and "ED"
For Each cel In rng
'below condition is to check if the string starts with "EDF"
If InStr(1, cel.Value, "EDF", 1) = 1 Then
'do nothing
'below condition is to check if the string starts with "ED"
ElseIf InStr(1, cel.Value, "ED", 1) = 1 Then
'drop first two characters of cell's value and write in Column M
cel.Offset(0, 10).Value = Right(cel.Value, Len(cel.Value) - 2)
'else condition will be executed when none of the above two conditions are satisfied
'else condition is based on the link mentioned in your question that will handle words like "ELECTRICAL BOX"
Else
'write cell's value in Column M
cel.Offset(0, 10).Value = cel.Value
End If
Next
End Sub
How's this work for you?
Sub move_Text()
Dim lastRow&, nextRow&
Dim cel As Range, rng As Range
lastRow = Cells(Rows.Count, 2).End(xlUp).Row ' Since your Col. B is the data, let's find that column's last row
Set rng = Range(Cells(1, 2), Cells(lastRow, 2))
nextRow = 1
For Each cel In rng
If Left(cel.Value, 2) = "ED" Then
Cells(nextRow, 13).Value = Mid(cel.Value, 3, Len(cel.Value) - 2)
nextRow = nextRow + 1
End If
Next cel
End Sub
It will set the range to be your Column B, from row 1 to the last row. Then, loop through each cell in there, checking the left two letters. If "ED", then move the data, but take off the "ED".
Edit: Just realized you're using VBScript. Remove the as Range and & from the declarations, so it's just Dim lastRow, nextRow, cel, rng.
If your criteria is met, this will copy values (minus the ED prefix) from Column B to Column M.
Sub move_Text()
Dim lastRow , i
lastRow = Cells(Rows.Count, 3).End(xlUp).Row
For i = 3 To lastRow
If Left(Cells(i, 3), 2) = "ED" And Not (Left(Cells(i, 3), 3) = "EDF") Then
Cells(i, 13).Value = Right(Cells(i, 3, Len(Cells(i, 3)) - 2)
End If
Next
End Sub
Why not use some of excel's formulas to speed the whole thing up:
Sub My_Amazing_Solution ()
Range("M3").FormulaR1C1 = "=IF(TRIM(LEFT(RC[-10],2))=""ED"",RIGHT(TRIM(RC[-10]),LEN(RC[-10])-2),"""")"
Range("M3").AutoFill Destination:=Range("M3:M" & Range("C1048576").End(xlUp).Row), Type:=xlFillDefault
Application.Wait Now + TimeValue("00:00:03")
Range("M3:M" & Range("C1048576").End(xlUp).Row).Copy
Range("M3").PasteSpecial xlPasteValues
End sub
This should do it for you!
I am trying to go through row 6 and from column 1 to 26 and search for the sentence Earned Cumulative Hours. Once that is done then I am trying to go from row 8 to the last row(30 in this case) for the column that has Earned Cumulative Hours in row 6.
Then I am trying to paste the values of the cells from this column to 2 cells left in the same row. But I keep getting errors and the code doesn't work.
Can someone please point me in the right direction ? Thanks
Sub project()
Dim lastrow As Long
Dim i As Long
Dim j As Long
lastrow = Sheets("Progress").Cells(Rows.Count, 26).End(xlUp).Row
For j = 1 To 26
If Cells(6, j) = "Earned Cumulative Hours" Then
For i = 8 To lastrow
Cells(i, j).Copy
Cells(i, j).Offset(0, -2).Select
Selection.PasteSpeical Paste:=xlPasteValues
Next i
End If
Next j
End Sub
There are a few problems I can see straight away with your code. Firstly if you are offsetting back two columns .Cells(i, j).Offset(0, -2) then you will be overwriting existing values. If this is what you intend to do then weird but ok.
The next issue is that you have a problem if 'Earned Cumulative Hours' is in Column A. If this is your case Excel will be most unhappy trying to offset two columns to the left and will give an error.
In this case instead of copying and pasting it will be more efficient to set values in one column to the other which you can see in my code. Finally, your Cell references will be valid for the active sheet only. You need to qualify what worksheet you interest in as shown in my code. I normally put this at the start of the code if it is a self contained block.
You could also eliminate the i loop and set ranges of values at a time but we'll save that for next time!
I haven't test this code but it should be fine.
Sub projectawesome()
Dim lastrow as Long, i as Long, j as Long
'Qualify the sheet (assuming its in the activeworkbook)
With Sheets("Progress")
lastrow = .Cells(.Rows.Count, 26).End(xlUp).Row
'I've changed this to column three to prevent offset errors.
For j = 3 to 26
If .Cells(6, j) = "Earned Cumulative Hours" Then
For i = 8 to lastrow
'Assuming overwriting data is ok.
'No need to copy and paste
.Cells(i, j - 2).Value = .Cells(i, j).Value
Next i
End If
Next
End With
End Sub
Try this and we can get rid of those selects
Sub project()
Dim lastrow As Long
Dim i As Long
Dim j As Long
lastrow = Sheets("Progress").Cells(Rows.Count, 26).End(xlUp).Row
For j = 1 To 26
If Cells(6, j) = "Earned Cumulative Hours" Then
For i = 8 To lastrow
Cells(i, j).Copy
With Cells(i, j)
.Offset(0, -2).PasteSpecial xlPasteValues
End With
Next i ' next row
End If
Next j ' next col
End Sub