I need to merge rows with same values on excel - I tried using pivot tables, and consolidate and I could not get the desired output. I need rows with same columns merged
Try,
Sub test()
Dim rngDB As Range
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Set rngDB = Range("b2", Range("b" & Rows.Count).End(xlUp))
MergeRange rngDB
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
Sub MergeRange(rngDB As Range)
Dim rng As Range
Dim rngO As Range, myCell As Range
Dim n As Integer
For Each rng In rngDB
If rng <> "" Then
n = WorksheetFunction.CountIf(rngDB, rng)
Set rngO = rng.Offset(, 1).Resize(n)
MergeRange rngO
For Each myCell In rngO
If myCell <> "" Then
myCell.Resize(WorksheetFunction.CountIf(rngO, myCell)).Merge
End If
Next myCell
rng.Resize(n).Merge
End If
Next rng
End Sub
Which column are you testing to do the consolidation? Is it B or C? Anyway, try this, and adjust the code to suit your specific needs.
Sub Macro()
Dim lngRow As Long
For lngRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
If StrComp(Range("B" & lngRow), Range("B" & lngRow - 1), vbTextCompare) = 0 Then
If Range("C" & lngRow) <> "" Then
Range("C" & lngRow - 1) = Range("C" & lngRow - 1) & "; " & Range("C" & lngRow)
End If
Rows(lngRow).Delete
End If
Next
End Sub
Before:
After:
Related
I adapted code I found online.
It finds the string "car" in column A and returns the rows as an array
It assigns a variable to the length of the array (how many matches it found)
It assigns a variable to generate a random number between 0 and the length of the array
It then prints a random matching row's value into K3
Dim myArray() As Variant
Dim x As Long, y As Long
Dim msg As String
With ActiveSheet.Range("A1:A" & ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row)
Set c = .find("Car", LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
ReDim Preserve myArray(y)
myArray(y) = c.Row
y = y + 1
Set c = .findNext(c)
If c Is Nothing Then
GoTo DoneFinding
End If
Loop While c.Address <> firstAddress
End If
DoneFinding:
End With
For x = LBound(myArray) To UBound(myArray)
msg = msg & myArray(x) & " "
Next x
ArrayLen = UBound(myArray) - LBound(myArray)
random_index = WorksheetFunction.RandBetween(0, ArrayLen)
MsgBox myArray(random_index)
Dim test As String
test = "B" & myArray(random_index)
Range("K3").Value = Range(test)
Example
I'm struggling with adapting the find code to allow for multiple criteria. So in my example, it finds "Car". What if I want to find matches that had "Car" in column A and "Red" in column D?
I tried
With ActiveSheet.Range("A1:A" & "D1:D" & ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row & ActiveSheet.Range("D" & Rows.Count).End(xlUp).Row)
Set c = .find("Car", "Red", LookIn:=xlValues)
I get type mismatch on the Set line.
In case it is confusing, it currently looks for a string e.g. "Car" but I will eventually link this to the variable which will be assigned to a data validation list. So if the user chooses "car" from a drop down list, this is what it will search for.
Maybe Advancde Filter is something that fit your needs:
Example Code
Option Explicit
Public Sub FilterData()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("YourSheetName")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim CriteriaRange As Range
Set CriteriaRange = ws.Range("A1", "E2")
Dim DataRange As Range
Set DataRange = ws.Range("A4", "E" & LastRow)
DataRange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=CriteriaRange, Unique:=False
End Sub
Public Sub ShowAll()
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
End Sub
Edit according comment:
You can use the advanced filter and then loop through the filter results:
Option Explicit
Public CurrentRow As Long
Public Sub FilterData()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("YourSheetName")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim CriteriaRange As Range
Set CriteriaRange = ws.Range("A1", "E2")
Dim DataRange As Range
Set DataRange = ws.Range("A4", "E" & LastRow)
DataRange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=CriteriaRange, Unique:=False
End Sub
Public Sub ShowAll()
On Error Resume Next
ActiveSheet.ShowAllData
CurrentRow = 1
On Error GoTo 0
End Sub
Public Sub GetNextResult()
FilterData
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("YourSheetName")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim DataRange As Range
Set DataRange = ws.Range("A4", "E" & LastRow)
Dim FilteredData As Range
Set FilteredData = DataRange.Resize(ColumnSize:=1).SpecialCells(xlCellTypeVisible)
If CurrentRow + 1 > FilteredData.Cells.Count Then
CurrentRow = 1
End If
CurrentRow = CurrentRow + 1
Dim i As Long
Dim Cell As Variant
For Each Cell In FilteredData
i = i + 1
If i = CurrentRow Then
Cell.EntireRow.Select
'or
'MsgBox Cell.Value & vbCrLf & Cell.Offset(0, 1) & vbCrLf & Cell.Offset(0, 2) & vbCrLf & Cell.Offset(0, 3) & vbCrLf & Cell.Offset(0, 4)
End If
Next Cell
End Sub
The code below executes but the:
For i = 2 To lRow
If .Range("A" & i).Value = rng1 Then
If .Range("C" & i).Value = rng2 Then
lastcell = .Range("B" & i).Value
End If
End If
Next i
Does not seem to be doing what I have intended. What I intended was that if the cell A & i's value = lets say rng1, if that is true then move on to the next parameter and check if that i's C column cell = rng2 if that is correct then take that row i's B column and set cell "C3" on the proof tab equal to B & i's value. Then move on to the next i; if it finds another B that fit the two conditions above, then set cell c3.offset(1) = to that i's value. This unfortunately is not working for me. ANyone have any suggestions :)
This is what it looks like when I run the code:
Sub Extract_Bank_Amount()
Dim wb As Workbook
Dim ws As Worksheet
Dim rng1 As Range, rng2 As Range, lastcell As Range
Dim lRow As Long, i As Long
Set wb = ActiveWorkbook
Set ws = wb.Sheets("Bank Statement")
Set rng1 = wb.Sheets("Payroll Journal").Range("B1")
Set rng2 = wb.Sheets("Payroll Journal").Range("B3")
Set lastcell = wb.Sheets("Proof").Range("C3" & Rows.Count).End(xlUp).Offset(1)
wb.Sheets("Bank Statement").Activate
With ws
lRow = .Range("B" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
If .Range("A" & i).Value = rng1 Then
If .Range("C" & i).Value = rng2 Then
lastcell = .Range("B" & i).Value
End If
End If
Next i
End With
End Sub
You need to find the next empty cell each time you add a value to the end of the list.
Sub Extract_Bank_Amount()
Dim wb As Workbook
Dim ws As Worksheet
Dim rng1 As Range, rng2 As Range, lastcell As Range
Dim lRow As Long, i As Long
Set wb = ActiveWorkbook
Set ws = wb.Sheets("Bank Statement")
Set rng1 = wb.Sheets("Payroll Journal").Range("B1")
Set rng2 = wb.Sheets("Payroll Journal").Range("B3")
wb.Sheets("Bank Statement").Activate
With ws
lRow = .Range("B" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
If .Range("A" & i).Value = rng1 Then
If .Range("C" & i).Value = rng2 Then
With wb.Sheets("Proof")
.Range("C" & .Rows.Count).End(xlUp).Offset(1).Value = .Range("B" & i).Value
End With
End If
End If
Next i
End With
End Sub
I would give the ranges on "Payroll Journal" meaningful names then used their Defined Names to refer to them.
wb.Sheets("Payroll Journal").Range("B1").Name = "PayrollB1"
wb.Sheets("Payroll Journal").Range("B3").Name = "PayrollB3"
This will allow you to get rid of a lot of the fluff.
Sub Extract_Bank_Amount2()
Dim cell As Range
With Worksheets("Bank Statement")
For Each cell In .Range("B" & .Rows.Count).End(xlUp)
If cell.Offset(0, -1).Value = Range("PayrollB1").Value Then
If cell.Offset(0, 1).Value = Range("PayrollB3").Value Then
With wb.Sheets("Proof")
.Range("C" & .Rows.Count).End(xlUp).Offset(1).Value = cell.Value
End With
End If
End If
Next
End With
End Sub
You should also download Rubberduck. Rubberduck is a COM add-in for the VBA IDE that will help you debug and optimise your code. Most importantly for me it saves me a ton of time by formatting my code for me.
Im looking to delete certain cells in all the columns on my worksheet if they contain 0 and then shift all the data upwards.
I found this formula on a different thread and it only worked for one column (column p) for some reason and only worked on half of that.
Hope you experts can help.
Option Explicit
Sub Sample()
Dim row_index As Long, lRow As Long, i As Long
Dim ws As Worksheet
Dim delRange As Range
'~~> Change this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
row_index = 7
Application.ScreenUpdating = False
With ws
lRow = .Range("P" & .Rows.Count).End(xlUp).Row
For i = row_index To lRow
If .Range("P" & i).Value <> "" And .Range("P" & i).Value = 0 Then
If delRange Is Nothing Then
Set delRange = .Range("P" & i)
Else
Set delRange = Union(delRange, .Range("P" & i))
End If
End If
Next
End With
If Not delRange Is Nothing Then delRange.Delete shift:=xlUp
Application.ScreenUpdating = True
End Sub
Try this:
Sub ZeroKiller()
Dim rKill As Range
Set rKill = Nothing
For Each r In ActiveSheet.UsedRange
If r.Value = 0 And r.Value <> "" Then
If rKill Is Nothing Then
Set rKill = r
Else
Set rKill = Union(rKill, r)
End If
End If
Next r
If rKill Is Nothing Then
Else
rKill.Delete Shift:=xlUp
End If
End Sub
Try the below code. The problem looks to be that your actual delete command is not in the loop, but at the end. So it only happens once. Also, Union() is unnecessary.
Sub Sample()
Dim lRow, i As Long
Dim ws As Worksheet
Dim delRange As Range
'~~> Change this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
Application.ScreenUpdating = False
With ws
lRow = .Range("P" & .Rows.Count).End(xlUp).Row
For i = lRow To 7 Step -1
If .Range("P" & i).Value <> "" And .Range("P" & i).Value = 0 Then
.Range("P" & i).Delete shift:=xlUp
End If
Next
End With
Application.ScreenUpdating = True
End Sub
What is up with .delete of a unioned range...?
I have three macros that compare two columns
The one I am using is vary slow on a large file but works
Sub MatchPermissionGiverAndTarget()
Dim LastRow As Long
Dim ws As Excel.Worksheet
GoFast False
Set ws = ActiveWorkbook.Sheets("Helper")
LastRow = ws.Range("A" & ws.Rows.count).End(xlUp).Row
Range("E1").EntireColumn.Insert
Range("E1").FormulaR1C1 = "name"
With ws.Range("E2:E" & LastRow)
.Formula = "=INDEX(B:B,MATCH($D2,$B:$B,0))"
.Value = .Value
End With
Columns("D:D").EntireColumn.Delete
GoFast True
End Sub
And this one I found by #mehow Here: Fast compare method of 2 columns
But I can not figure out how to apply it so it dose what the first one dose
Any help on this is appreciated
Sub Main()
Application.ScreenUpdating = False
Dim stNow As Date
stNow = Now
Dim arr As Variant
arr = Range("B2:A" & Range("B" & Rows.Count).End(xlUp).Row).Value
Range("E1").EntireColumn.Insert
Range("E1").FormulaR1C1 = "name"
Dim varr As Variant
varr = Range("D2:D" & Range("D" & Rows.Count).End(xlUp).Row).Value
Dim x, y, match As Boolean
For Each x In arr
match = False
For Each y In varr
If x = y Then match = True
Next y
If Not match Then
Range("D" & Range("D" & Rows.Count).End(xlUp).Row + 1) = x
End If
Next
Columns("D:D").EntireColumn.Delete
Debug.Print DateDiff("s", stNow, Now)
Application.ScreenUpdating = True
End Sub
Or This one from same thread by #Reafidy
Sub HTH()
Application.ScreenUpdating = False
With Range("E2", Cells(Rows.Count, "E").End(xlUp)).Offset(, 1)
.Formula = "=VLOOKUP(B2,D:D,1,FALSE)"
.Value = .Value
.SpecialCells(xlCellTypeConstants, 16).Offset(, -1).Copy Range("D" & Rows.Count).End(xlUp).Offset(1)
.ClearContents
End With
Application.ScreenUpdating = True
End Sub
try this one:
Sub Main()
Dim ws As Worksheet
Dim stNow As Date
Dim lastrow As Long, lastrowB As Long
Dim match As Boolean
Dim k As Long
Dim arr, varr, v, a, res
Application.ScreenUpdating = False
stNow = Now
Set ws = ActiveWorkbook.Sheets("Helper")
With ws
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
lastrowB = .Range("B" & .Rows.Count).End(xlUp).Row
arr = .Range("B2:B" & lastrowB).Value
varr = .Range("D2:D" & lastrow).Value
.Range("E1").EntireColumn.Insert
.Range("E1").FormulaR1C1 = "name"
End With
k = 1
ReDim res(1 To lastrow, 1 To 1)
For Each v In varr
match = False
'if value from column D (v) contains in column B
For Each a In arr
If a = v Then
match = True
Exit For
End If
Next a
If match Then
res(k, 1) = v
Else
res(k, 1) = CVErr(xlErrNA)
End If
k = k + 1
Next v
With ws
.Range("E2:E" & lastrow).Value = res
.Range("D:D").Delete
End With
Debug.Print DateDiff("s", stNow, Now)
Application.ScreenUpdating = True
End Sub
I need to compare values on two separate sheets, both are in column H starting at 2. One sheet is labeled final, the other data. If it is in final and not in data then highlight in final. If something found in data is not in final copy it into final (whole row) at the bottom. It is all text. Column H is titled "Reference".
code 1
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Column <> 8 Then Exit Sub
Dim lastRow As Long
Dim rng As Range, cell As Range
lastRow = Range("H" & Rows.Count).End(xlUp).Row
If lastRow < 2 Then lastRow = 2
Set rng = Range("H2:H" & lastRow)
For Each cell In rng
With Sheets("data")
a = Application.VLookup(cell.Value, .Range("H2:H" & .Range("H" & Rows.Count).End(xlUp).Row), 1, 0)
If IsError(a) Then
cell.Interior.Color = vbYellow
Else
cell.Interior.Color = xlNone
End If
End With
Next
Application.EnableEvents = True
End Sub
code 2
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Column <> 8 Then Exit Sub
Dim lastRow As Long
Dim rng As Range, cell As Range
lastRow = Range("H" & Rows.Count).End(xlUp).Row
If lastRow < 2 Then lastRow = 2
Set rng = Range("H2:H" & lastRow)
For Each cell In rng
With Sheets("final")
a = Application.VLookup(cell.Value, .Range("H2:H" & .Range("H" & Rows.Count).End(xlUp).Row), 1, 0)
If IsError(a) Then
cell.Copy .Range("H" & .Range("H" & Rows.Count).End(xlUp).Row)
End If
End With
Next
Application.EnableEvents = True
End Sub