The goal is to compare for two matches on two columns between two similarly formatted sheets for a matching row. Once matched, we would sort through each column of the matched rows and replace data from sht3 onto sht2 to add updated info.
I have considered using dictionary objects for the matching but haven't figured it out, you can see that by trying to match two columns between two sheets, this gets very time consuming when there are (possibly tens of) thousands of rows.
Is there an alternative to dictionaries , if not then how would I bets implement them?
I'm not sure if the following function is relevant but thought I'd include the whole picture.
Private Sub update_tracking(sht2 As Worksheet, sht3 As Worksheet, refsht As Worksheet)
Dim excludearr As Variant, termarr() As Variant
Dim sht2count As Long, i As Long, x As Long
Dim sht2rng As Range, cell As Range, pool As Range
'need to find a more efficient way of this
' for sht3sht, i is rows and j is columns
sht2count = Application.CountA(sht2.Range("A:A"))
Set sht2rng = sht2.Range("A2:A" & sht2count)
i = 2
Do While i <= sht2count
For Each cell In sht2rng
If cell.Value = sht3.Cells(i, 1) And cell.Offset(0, 2).Value = sht3.Cells(i, 3) Then
'call update function
Update_cells cell, sht3, i
sht3.Cells(i, 1).EntireRow.Delete
i = i - 1
End If
Next
i = i + 1
Loop
Function Update_cells(cell As Range, sht3 As Worksheet, i As Long)
Dim excludearr As Variant, j As Long
j = 1
'Add column max range
Do While j <= 35
'Adds exclusion columns
excludearr = Array(1, 3, 12, 26, 29)
If Not IsNumeric(Application.Match(j, excludearr, 0)) Then
If sht3.Cells(i, j) <> "" And sht3.Cells(i, j) <> cell.Offset(0, (j - 1)) Then
sht3.Cells(i, j).Copy
cell.Offset(0, (j - 1)).PasteSpecial Paste:=xlPasteAll
cell.Offset(0, (j - 1)).Interior.Color = vbYellow
End If
End If
j = j + 1
Loop
End Function
Related
I have a table with information in column A and an appropriate value in column B. I want to write a macro that inserts a new row for each "Person" in dependence of the value in column B and copies the original information into that row, which for example means that in the end there are 5 rows with "Person A", 2 rows for "Person B" etc.
original table:
result:
My first approach looks like that. It doesn't work.
Dim i, j, k As Integer
For i = Range("A" & Range("A:A").Rows.Count).End(xlUp).Row To 1 Step -1
For j = 1 To Range("B" & i)
Rows(i).Select
Selection.Insert Shift:=xlDown
k = k + j
Range(Cells(k, 1), Cells(k, 2)).Copy Destination:=Range("A" & i)
Next j
Next i
This would work for you, changing the number of inserts based on value in column B:
Option Explicit
Sub test()
With Sheets(1)
Dim lastRow As Long: lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim i As Long
For i = lastRow To 1 Step -1
If IsNumeric(.Cells(i, 2).Value) = True Then
Dim numberOfInserts As Long
numberOfInserts = .Cells(i, 2).Value - 1
If numberOfInserts > 0 Then
Dim insertCount As Long
For insertCount = 1 To numberOfInserts
.Rows(i).Copy
.Rows(i).Insert
Next insertCount
End If
End If
Next i
End With
End Sub
First we check that you're dealing with numbers. Second you have a single line already, so number -1, then that this number is >0. Lastly, you insert via a loop which does the counting for you.
Test data:
Output after running:
Your index calculation is messed up. Use the debugger, step thru the code (F8) and notice what happens:
a) Your Select/Insert-construct creates a new row above the row you want to copy, not below.
b) Your calculation of index k fails: You are not initializing k, so it starts with value 0. Than you add j (1..3) to k, resulting in values 1, 3, 6, and copy data from that line.
I would suggest you take a different approach: Copy the original data into an array and then loop over that array. This avoids multiple Select, Copy and Insert statements (that are slow) and allow to copy the data from top to bottom.
Sub copy()
Dim rowCount As Long
Dim data As Variant
With ActiveSheet ' Replace with the sheet you want to work with
' Copy the current table into array
rowCount = .Cells(.Rows.Count, 1).End(xlUp).row
data = .Range(.Cells(1, 1), .Cells(rowCount, 2))
Dim oldRow As Long, newRow As Long
newRow = 1
' Loop over old data
For oldRow = 1 To rowCount
Dim repeatCount As Long
repeatCount = Val(data(oldRow, 2)) ' We want to have so many occurrences of the row
if repeatCount <= 0 Then repeatCount=1
Dim col As Long
' Create "repeatCount" rows of data (copy column by column)
For col = 1 To 2
.Cells(newRow, col).Resize(repeatCount, 1) = data(oldRow, col)
Next col
newRow = newRow + repeatCount
Next
End With
End Sub
Regarding this question “combine or merge cells with the same values vertically and horizontally” Link,
the provided answer (edited one) it works ,but with big range (e.g. 30 thousands rows) the macro takes a very long time to finish (no error raised but excel is not responding).
so, instead of putting only the first column on array,
Is it possible to move all the usedRange into array and processing all the tasks on memory and then copy back to the sheet?
I do not care about any lost format at all (fonts, rows height,..).
In advance, grateful for your helps.
Sub DeleteSimilarRows_AppendLastColuns()
Dim LastRow As Long, ws As Worksheet, arrWork, rngDel As Range, i As Long, j As Long, k As Long
Dim strVal As String, m As Long, boolNoFilter As Boolean
Set ws = ActiveSheet: LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
arrWork = ws.Range("A1:A" & LastRow).Value2 'Place the range in an array to make iteration faster
Application.DisplayAlerts = False: Application.ScreenUpdating = False
For i = 2 To UBound(arrWork) - 1 'Iterate between the array elements:
If arrWork(i, 1) = arrWork(i + 1, 1) Then
'Determine how many consecutive similar rows exist:__________________
For k = 1 To LastRow
If i + k + 1 >= UBound(arrWork) Then Exit For
If arrWork(i, 1) <> arrWork(i + k + 1, 1) Then Exit For
Next k '___________________________________________
For j = 14 To 14 'Build the concatenated string of cells in range "N":
strVal = ws.Cells(i, j).Value
For m = 1 To k
strVal = strVal & vbLf & ws.Cells(i + m, j).Value
Next m
ws.Cells(i, j).Value = strVal: strVal = ""
Next j
For m = 1 To k 'Place the cells for rows to be deleted in a Union range, to delete at the end, at once
If rngDel Is Nothing Then
Set rngDel = ws.Range("A" & i + m)
Else
Set rngDel = Union(rngDel, ws.Range("A" & i + m))
End If
Next m
i = i + k: If i >= UBound(arrWork) - 1 Then Exit For 'Increment the i variable and exiting if the resulted value exits the array size
End If
Next i
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete 'Delete the not necessary rows
Application.DisplayAlerts = True: Application.ScreenUpdating = True
End Sub
It is not only possible, but preferable. The speed increase is insane. This is how I do it:
Data from the spread sheet gets saved into a variable from type Variant -- the result is a 2-dimensional array (even if there is only one row/column in the range).
' Read data into Array
Dim data as Variant ' Important: has to be type Variant.
Set data = ActiveSheet.UsedRange.Value2 ' .Value or .Value2, as needed
When saving data back into the sheet, this code automatically selects a range of the appropriate size.
' Write array into cells
Dim target as Range
Set target = ActiveSheet.Cells(1,1) ' Start at A1 / R1C1; Change as appropriate
target.Resize(UBound(data, 1), UBound(data, 2)).Value = data
I am trying to do a "for each" sub in VBA, comparing two pairs of rows and the values in each cell to one another. For example row 2 is compared with row 3, row 4 is compared with row 5 etc. I need the code to highlight the differences in each cell for each of the comparisons. This is what I have so far and I cannot seem to get it to work. Any thought?
Sub testing_2()
Dim rw_2 As Range, rw_1 As Range, decisions As String
decisions = MsgBox("Check accuracy?", vbYesNo)
If decisions = vbYes Then
For Each rw_1 In Worksheets("worksheet").Rows
For Each rw_2 In Worksheets("worksheet").Rows
If Not StrComp(rw_1.row Mod 2 = 0, rw_2.row Mod 2 = 1, vbBinaryCompare) = 0 Then
Range(rw_1.row Mod 2 = 0, rw_2.row Mod 2 = 1).Interior.ColorIndex = 6
End If
Next rw_2
Next rw_1
Else: End If
End Sub
Thank you!
Basically, I am looking at each row, two at a time, and highlighting the different values between them.
One loop to to loop the rows stepping 2 rows at a time and another loop to loop the columns
Sub testing_2()
decisions = MsgBox("Check accuracy?", vbYesNo)
If decisions = vbYes Then
With Worksheets("Sheet4") ' change to your sheet
Dim lstRw As Long
lstRw = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim lstClm As Long
lstClm = .Cells(1, Columns.Count).End(xlToLeft).Column
Dim i As Long
For i = 2 To lstRw Step 2
Dim j As Long
For j = 2 To lstClm
If .Cells(i, j) <> .Cells(i + 1, j) Then
.Range(.Cells(i, j), .Cells(i + 1, j)).Interior.ColorIndex = 6
End If
Next j
Next i
End With
End If
End Sub
So the code below copies data from two columns in one sheet. Pastes these so that values are displayed in another sheet (because one column is a formula =Left(Column+1,4)) and then attempts to run a remove duplicates across the two columns that are pasted.
This takes roughly 30 minutes to run on what is essentially 100k cells (2 columns of 50k rows each).
This is what I've been using
Sub ProjTrending1()
Dim s1 As Worksheet, s2 As Worksheet
Dim St As Date, Et As Date
Dim Tt As Double
St = Time
Application.ScreenUpdating = False
'Defines S1 as a Worksheet
Set s1 = Sheets("All Data")
'Defines S2 as WorkSheet
Set s2 = Sheets("Workings")
'Defines LastR1
Dim LR1 As Long
Dim LR2 As Long
'Finds last row cell working sheet
LR2 = s1.Cells(Rows.Count, 10).End(xlUp).Row
'Takes Data from Order Column of defined data Sheet and copy & pastes it to Working Sheet Column B
s1.Range("J1:J" & LR2).Copy s2.Range("A1")
s1.Range("e1:e" & LR2).Copy
s2.Range("b1").PasteSpecial Paste:=xlPasteValues
LR1 = s2.Range("A1").CurrentRegion.Rows.Count
'Removes Duplicates from Column B Working sheet
s2.Range("A2:B" & LR1).RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo
'Copies the formula from C2 and applies it to all cells in column C where column A has values (simple concatenate + countifs(B$2:B2,B2)
s2.Range("C2").Copy s2.Range("C2:C" & LR1)
Et = Time
Tt = (Et - St) * 24 * 60 * 60
MsgBox Timetaken
End Sub
I've also tried using a dictionary to do this but I'm new to dictionaries so whilst the code looks good compared to my usual attempts its because its taken from a couple of different sources. (Copied and Pasted the data to sheet2 incase this overwrote the source data)
Sub M_delete_duplicates()
sn = Sheets("Sheet2").Cells(1).CurrentRegion.Resize(, 5)
With CreateObject("scripting.dictionary")
For j = 1 To UBound(sn)
.Item(sn(j, 1)) = Application.Index(sn, j, 0)
Next
Sheets("Sheet2").Cells(1, 4).Resize(.Count, UBound(sn, 2)) = Application.Index(.Items, 0, 0)
End With
End Sub
This is as slow to run and it only does remove duplicates based on single column and I need it to operate on two columns. The potential way around this is to concatenate the two columns of data and run the remove duplicates once and then break the data using =right(Value,X)
If wanted to do it manually it takes 30 seconds max. It makes no sense to me as to why it takes so long to run.
Can anyone help with why this might be taking so long to run? and how I might modify the dictionary code to remove duplicates over two columns?
Thanks in advance
Updated from my comment. This uses a dictionary to track which rows have been added and then copies unique rows across to the destination sheet. You may want to modify it a bit for your use (e.g. update sheet names) Always test this first on a copy of your data set or make a back up before running code
Option Explicit
Public Sub ExampleRemoveDuplicates()
Dim dict As Object
Dim temp As String
Dim calc As String
Dim headers As Variant
Dim NoCol As Long, NoRow As Long, i As Long, j As Long
Dim c, key
With Application
.ScreenUpdating = False
calc = .Calculation
.Calculation = xlCalculationManual
End With
Set dict = CreateObject("Scripting.Dictionary")
' Change this to the sheet that is applicable
With Sheet1
NoCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
' Assumes first row of sheet is headers
headers = .Range(.Cells(1, 1), .Cells(1, NoCol)).Value2
' Change this to destination sheet
With Sheet2
.Cells.Clear
.Range(.Cells(1, 1), .Cells(1, NoCol)).Value2 = headers
End With
For Each c In .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1))
ReDim arr(1 To NoCol)
j = 1
Do
arr(j) = c.Offset(0, j - 1).Value2
j = j + 1
Loop Until j = NoCol + 1
temp = Join(arr, "//")
If Not dict.exists(temp) And Not temp = vbNullString Then
dict.Add key:=temp, Item:=arr
' Change this to destination sheet
With Sheet2
NoRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Range(.Cells(NoRow, 1), .Cells(NoRow, NoCol)).Value2 = arr
End With
End If
Next c
End With
i = 1
ReDim Results(1 To dict.Count, 1 To NoCol)
For Each key In dict.keys
For j = 1 To NoCol
Results(i, j) = dict(key)(j)
Next j
i = i + 1
Next key
' Change this to destination sheet
With Sheet2.Cells(1, 1)
.Range(.Offset(1, 0), .Offset(dict.Count, NoCol - 1)) = Results
End With
With Application
.Calculation = calc
.ScreenUpdating = True
End With
End Sub
I am trying to calculate some values from specific columns in Sheet1 and Sheet2. The problem is that the Sub below first correctly calculates the numbers from a matrix in Sheet1. It puts the matrix in some cells on Sheet1. And then the code rewrites that matrix with the numbers from Sheet2. But I want to put the calculations from Sheet2 on Sheet2, not Sheet1. Any ideas about what I am doing wrong? Best Regards!
Sub Try()
Dim LastRow As Long
Dim LastOne As Long
Dim Sheetz As Variant
Sheetz = Array("Sheet1", "Sheet2")
For h = LBound(Sheetz) To UBound(Sheetz)
With Worksheets(Sheetz(h))
numbers = Array(1, 2, 3)
For j = LBound(numbers) To UBound(numbers)
For i = 1 To 3
LastRow = .Cells(.Rows.Count, i).End(xlUp).Row
LastValue = .Cells(.Rows.Count, i).End(xlUp).Value
FirstOne = .Cells(LastRow - j, i).Value
Cells(i + 1, j + 5) = LastValue / FirstOne - 1
Next i
Next j
End With
Next h
End Sub