Related
I'm looking for a way to speed up this code as it takes my computer 20-30 minutes to run. It essentially runs through a list of column values in sheet "A" and if It matches a column value in sheet "B" it will pull the entire corresponding row to the sheet "Match".
Sub MatchSheets()
Dim lastRowAF As Integer
Dim lastRowL As Integer
Dim lastRowM As Integer
Dim foundTrue As Boolean
Application.ScreenUpdating = False
lastRowAF = Sheets("FHA").Cells(Sheets("FHA").Rows.Count, "AF").End(xlUp).Row
lastRowL = Sheets("New Construction").Cells(Sheets("New Construction").Rows.Count, "L").End(xlUp).Row
lastRowM = Sheets("Match").Cells(Sheets("Match").Rows.Count, "A").End(xlUp).Row
For i = 1 To lastRowAF
foundTrue = False
For j = 1 To lastRowL
If Sheets("FHA").Cells(i, 32).Value = Sheets("New Construction").Cells(j, 12).Value Then
foundTrue = True
Exit For
End If
Next j
If foundTrue Then
Sheets("FHA").Rows(i).Copy Destination:= _
Sheets("Match").Rows(lastRowM + 1)
lastRowM = lastRowM + 1
End If
Next i
Application.ScreenUpdating = True
End Sub
Collections are optimized for looking values. Using a combination of a Collection and Array is usually the best way to match two list. 20K Rows X 54 Columns (140K Values) took this code 10.87 seconds to copy over on a slow PC.
Sub NewMatchSheets()
Dim t As Double: t = Timer
Const NUM_FHA_COLUMNS As Long = 54, AF As Long = 32
Dim list As Object
Dim key As Variant, data() As Variant, results() As Variant
Dim c As Long, r As Long, count As Long
ReDim results(1 To 50000, 1 To 100)
Set list = CreateObject("System.Collections.ArrayList")
With ThisWorkbook.Worksheets("New Construction")
data = .Range("L1", .Cells(.Rows.count, "L").End(xlUp)).Value
For Each key In data
If key <> "" Then
If Not list.Contains(key) Then list.Add key
End If
Next
End With
With ThisWorkbook.Worksheets("FHA")
data = .Range(.Range("A1").Resize(1, NUM_FHA_COLUMNS), .Cells(.Rows.count, AF).End(xlUp)).Value
For r = 1 To UBound(data)
key = data(r, AF)
If list.Contains(key) Then
count = count + 1
For c = 1 To UBound(data, 2)
results(count, c) = data(r, c)
Next
End If
Next
End With
If count = 0 Then Exit Sub
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = True
With ThisWorkbook.Worksheets("Match")
With .Cells(.Rows.count, "A").End(xlUp)
.Offset(1).Resize(count, NUM_FHA_COLUMNS).Value = results
End With
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = False
Debug.Print Round(Timer - t, 2)
End Sub
use variant arrays:
Sub MatchSheets()
Dim lastRowAF As Long
Dim lastRowL As Long
Dim lastRowM As Long
Application.ScreenUpdating = False
lastRowAF = Sheets("FHA").Cells(Sheets("FHA").Rows.Count, "AF").End(xlUp).Row
lastRowL = Sheets("New Construction").Cells(Sheets("New Construction").Rows.Count, "L").End(xlUp).Row
lastRowM = Sheets("Match").Cells(Sheets("Match").Rows.Count, "A").End(xlUp).Row
Dim FHAArr As Variant
FHAArr = Sheets("FHA").Range(Sheets("FHA").Cells(1, 1), Sheets("FHA").Cells(lastRowAF, Columns.Count).End(xlToLeft)).Value
Dim NewConArr As Variant
NewConArr = Sheets("New Construction").Range(Sheets("New Construction").Cells(1, 12), Sheets("New Construction").Cells(lastRowL, 12)).Value
Dim outarr As Variant
ReDim outarr(1 To UBound(FHAArr, 1), 1 To UBound(FHAArr, 2))
Dim k As Long
k = 0
Dim l As Long
For i = 1 To lastRowAF
For j = 1 To lastRowL
If FHAArr(i, 32) = NewConArr(j, 1) Then
For l = 1 To UBound(FHAArr, 2)
k = k + 1
outarr(k, l) = FHAArr(i, l)
Next l
Exit For
End If
Next j
Next i
Sheets("Match").Cells(lastRowM + 1, 1).Resize(UBound(outarr, 1), UBound(outarr, 2)).Value = outarr
Application.ScreenUpdating = True
End Sub
FHA Worksheet: 2500 rows by 50 columnsNew Construction Worksheet: 500 rows by 1 column LMatch Worksheet: 450 transfers from FMA Elapsed time: 0.13 seconds
Get rid of all the nested loop and work with arrays.
Your narrative seemed to suggest that there might be multiple matches for any one value but your code only looks for a single match then Exit For. I'll work with the latter of the two scenarios.
Sub MatchSheets()
Dim i As Long, j As Long
Dim vFM As Variant, vNC As Variant
Debug.Print Timer
With Worksheets("New Construction")
vNC = .Range(.Cells(1, "L"), _
.Cells(.Rows.Count, "L").End(xlUp)).Value2
End With
With Worksheets("FHA")
vFM = .Range(.Cells(1, "A"), _
.Cells(.Rows.Count, _
.Cells(1, .Columns.Count).End(xlToLeft).Column).End(xlUp)).Value2
End With
ReDim vM(LBound(vFM, 2) To UBound(vFM, 2), 1 To 1)
For i = LBound(vFM, 1) To UBound(vFM, 1)
If Not IsError(Application.Match(vFM(i, 32), vNC, 0)) Then
For j = LBound(vFM, 2) To UBound(vFM, 2)
vM(j, UBound(vM, 2)) = vFM(i, j)
Next j
ReDim Preserve vM(LBound(vFM, 2) To UBound(vFM, 2), LBound(vM, 2) To UBound(vM, 2) + 1)
End If
Next i
With Worksheets("match")
.Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(UBound(vM, 2), UBound(vM, 1)) = _
Application.Transpose(vM)
End With
Application.ScreenUpdating = True
Debug.Print Timer
End Sub
Try changing this line:
Sheets("FHA").Rows(i).Copy Destination:= _
Sheets("Match").Rows(lastRowM + 1)
For the following line:
Sheets("Match").Rows(lastRowM + 1).Value for Sheets("FHA").Rows(i).value
If you really need to shave milliseconds, you could also set: lastRowM to be:
lastRowM = Sheets("Match").Cells(Sheets("Match").Rows.Count, "A").End(xlUp).Row + 1
And use:
Sheets("Match").Rows(lastRowM).Value for Sheets("FHA").Rows(i).value
Thus saving you an addition every time you go through that part of the code
I'm trying to figure out how to start an autofill based on a dynamic range. For each column in the 'starting table' I need to stack them on top of one another. My current code starting at 'LastRow' does not do this. I was hoping LastRow would give me a dynamic Range to autofill from, but instead I get the error,
'Object variable or With block variable not set'
How do I change my code so that '2Move' autofills to the new size of the table, without knowing where it starts? Then repeat the process for '3Move' and '4Move'
Sub shiftingColumns()
Dim sht As Worksheet
Dim LastRow As Range
Set sht = ActiveSheet
Set copyRange = Sheets("Sheet1").Range(Range("A2:B2"), Range("A2:B2").End(xlDown))
'Insert column & add header
Columns("C:C").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("C1").Value = "Category"
'Move D1 Value to C2
Range("D1").Cut Destination:=Range("C2")
'Autofill C2 value to current table size
Range("C2").AutoFill Destination:=Range("C2:C" & Range("A" & Rows.Count).End(xlUp).Row)
'Copy copyRange below itself
copyRange.Copy Destination:=Range("A" & Rows.Count).End(xlUp).Offset(1)
'Move E1 below autofilled ranged
Range("E1").Cut Destination:=Range("C" & Rows.Count).End(xlUp).Offset(1)
'LastRow = sht.Cells(sht.Rows.Count, "C").End(xlUp).Row
'LastRow.AutoFill Destination:=Range(LastRow & Range("A" & Rows.Count).End(xlUp).Row)
End Sub
This is the starting table
This is the desired table
For the benefit of those finding this via search engine, what you're looking to do isn't anything like autofill.
This should work for you, a loop.
Sub test()
workingSheet = ActiveSheet.Name
newSheet = "New Sheet"
On Error Resume Next
Application.DisplayAlerts = False
Sheets(newSheet).Delete
Application.DisplayAlerts = True
Sheets.Add.Name = newSheet
Cells(1, 1) = "ID"
Cells(1, 2) = "Color"
Cells(1, 3) = "Category"
On Error GoTo 0
Sheets(workingSheet).Activate
'Get last column
x = Cells(1, 3).End(xlToRight).Column
y = Cells(1, 1).End(xlDown).Row
'Loop for each column from 3 (column "C") and after
For i = 3 To x
With Sheets(newSheet)
newRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
'Copy ID and Color
Range(Cells(2, 1), Cells(y, 2)).Copy .Range(.Cells(newRow, 1), .Cells(newRow + y, 2))
'Copy column header
.Range(.Cells(newRow, 3), .Cells(newRow + (y - 2), 3)) = Cells(1, i)
'Copy column values
Range(Cells(2, i), Cells(y, i)).Copy .Range(.Cells(newRow, 4), .Cells(newRow + y, 4))
End With
Next
End Sub
If your demands vary, such as adding other "fixed" columns like ID and Color then you'll have to change the cell addressing and such.
These two method will transpose the data much faster than Range.Copy and Range.Paste.
PivotTableValues - dumps the Range.Value into an array, data, then fills a second array, results, with the transposed values. Note: Transposed in this context simply means moved to a different place.
PivotTableValues2 - uses Arraylists to accomplish the OP's goals. Although it works great, it is somewhat a farcical answer. I just wanted to try this approach for esoteric reasons.
PivotTableValues Using Arrays
Sub PivotTableValues()
Const FIXED_COLUMN_COUNT As Long = 2
Dim ArrayRowCount As Long, Count As Long, ColumnCount As Long, RowCount As Long, x As Long, y As Long, y2 As Long
Dim data As Variant, results As Variant, v As Variant
With ThisWorkbook.Worksheets("Sheet1")
RowCount = .Range("A" & .Rows.Count).End(xlUp).Row
ColumnCount = .Cells(1, .Columns.Count).End(xlToLeft).Column
data = Range(.Range("A" & .Rows.Count).End(xlUp), .Cells(1, .Columns.Count).End(xlToLeft)).Value
ArrayRowCount = (ColumnCount - FIXED_COLUMN_COUNT) * (RowCount - 1) + 1
ReDim results(1 To ArrayRowCount, 1 To FIXED_COLUMN_COUNT + 2)
Count = 1
For y = FIXED_COLUMN_COUNT + 1 To ColumnCount
For x = 2 To RowCount
Count = Count + 1
results(Count, FIXED_COLUMN_COUNT + 1) = data(1, y)
results(Count, FIXED_COLUMN_COUNT + 2) = data(x, y)
For y2 = 1 To FIXED_COLUMN_COUNT
If Count = 2 Then
results(1, y2) = data(1, y2)
results(1, y2 + 1) = "Category"
results(1, y2 + 2) = "Value"
End If
results(Count, y2) = data(x, y2)
Next
Next
Next
End With
With ThisWorkbook.Worksheets.Add
.Range("A1").Resize(UBound(results), UBound(results, 2)).Value = results
.Columns.AutoFit
End With
End Sub
PivotTableValues2 Using ArrayLists
Sub PivotTableValues2()
Const FIXED_COLUMN_COUNT As Long = 2
Dim ColumnCount As Long, RowCount As Long, x As Long, y As Long
Dim valueList As Object, baseList As Object, results As Variant, v As Variant
Set valueList = CreateObject("System.Collections.ArrayList")
Set baseList = CreateObject("System.Collections.ArrayList")
With ThisWorkbook.Worksheets("Sheet1")
RowCount = .Range("A" & .Rows.Count).End(xlUp).Row
ColumnCount = .Cells(1, .Columns.Count).End(xlToLeft).Column
For x = 1 To RowCount
baseList.Add Application.Transpose(Application.Transpose(Range(.Cells(x, 1), .Cells(x, FIXED_COLUMN_COUNT))))
Next
For y = FIXED_COLUMN_COUNT + 2 To ColumnCount
baseList.AddRange baseList.getRange(1, RowCount - 1)
Next
For y = FIXED_COLUMN_COUNT + 1 To ColumnCount
For x = 2 To RowCount
valueList.Add Array(.Cells(1, y).Value, .Cells(x, y).Value)
Next
Next
End With
results = Application.Transpose(Application.Transpose(baseList.ToArray))
With ThisWorkbook.Worksheets.Add
.Range("A1").Resize(UBound(results), UBound(results, 2)).Value = results
valueList.Insert 0, Array("Category", "Value")
results = Application.Transpose(Application.Transpose(valueList.ToArray))
.Cells(1, FIXED_COLUMN_COUNT + 1).Resize(UBound(results), UBound(results, 2)).Value = results
.Columns.AutoFit
End With
End Sub
Have data spread across columns
Want to keep the first three columns fixed (columns a, b and c).
And convert columns from four onward into new rows (columns d --> last column where there is a value).
Example:
The colours from columns D -->onwards are NOT always green, blue, black red, etc.... they vary depending on the data loaded in from a power query table.
This is how I want the data to look:
Notice how columns A, B and C are fixed with the same info and only columns D onwards is recreating a new "row".
I've been trying to adapt a VBA script from a previous post on here, but I'm having some complications. I'm also trying to keep it on the sheet that the data is currently on, not create a new sheet. If it is easier to just create a new sheet.. then I can work with that.. Script:
Sub ColumnTorow()
Dim maxRows As Double
Dim maxCols As Integer
Dim data As Variant
maxRows = Cells(1, 1).End(xlDown).row
maxCols = Cells(1, 1).End(xlToRight).Column
data = Range(Cells(1, 1), Cells(maxRows, maxCols))
With ActiveSheet
Dim rRow As Long
rRow = 2
Dim row As Long
row = 2
Dim col As Integer
Do While True
col = 2
Do While True
If data(row, col) = "" Then Exit Do 'Skip Blanks
.Cells(rRow, 1).Value = data(row, 1)
.Cells(rRow, 2).Value = data(row, col)
rRow = rRow + 1
If col = maxCols Then Exit Do 'Exit clause
col = col + 1
Loop
If row = maxRows Then Exit Do 'exit cluase
row = row + 1
Loop
End With
End Sub
This is just an example code that I was provided with and I'm trying to modify... It might not even be the correct solution to this problem but figured I would post it anyways.
Here you go, since I did this yesterday, I got it together fairly quickly:
Sub ColumnToRow()
Dim maxRows As Double
Dim maxCols As Integer
Dim data As Variant
maxRows = Cells(1, 1).End(xlDown).row
maxCols = Cells(1, 1).End(xlToRight).Column
data = Range(Cells(1, 1), Cells(maxRows, maxCols))
Dim newSht As Worksheet
Set newSht = Sheets.Add
With newSht
.Cells(1, 1).Value = data(1, 1)
.Cells(1, 2).Value = data(1, 2)
.Cells(1, 3).Value = data(1, 3)
.Cells(1, 4).Value = data(1, 4)
Dim writeColumn As Double
writeColumn = 1
Dim writeRow As Double
writeRow = 2
Dim row As Double
row = 2
Do
writeColumn = 1
Dim col As Double
col = 4
Do While True
If data(row, col) <> "" Then
Dim firstColData As String
firstColData = data(row, 1)
.Cells(writeRow, writeColumn) = firstColData
writeColumn = 2
Dim secondColData As String
secondColData = data(row, 2)
.Cells(writeRow, writeColumn) = secondColData
writeColumn = 3
Dim thirdColData As String
thirdColData = data(row, 3)
.Cells(writeRow, writeColumn) = thirdColData
writeColumn = 4
.Cells(writeRow, writeColumn).Value = data(row, col)
writeColumn = 1
writeRow = writeRow + 1
End If
If col = maxCols Then
Exit Do 'Exit clause
End If
col = col + 1
Loop
If row = maxRows Then
Exit Do 'exit cluase
End If
row = row + 1
Loop While True
End With
End Sub
consider this code.
Sub TransData()
Dim vDB, vR()
Dim n As Long, i As Long, j As Integer, k As Integer
vDB = Range("a1").CurrentRegion
For i = 2 To UBound(vDB, 1)
For j = 4 To UBound(vDB, 2)
If vDB(i, j) <> "" Then
n = n + 1
ReDim Preserve vR(1 To 4, 1 To n)
For k = 1 To 3
vR(k, n) = vDB(i, k)
Next k
vR(4, n) = vDB(i, j)
End If
Next j
Next i
Sheets.Add
Range("a1").Resize(1, 4) = Array("Item", "Amount", "Price", "Color")
Range("a2").Resize(n, 4) = WorksheetFunction.Transpose(vR)
End Sub
I've been working on a VBA script for a while now that goes through the values of a column and deletes all rows with values appearing only once (pretty much the inverse of deleting duplicates).
Column Headers to make explanation easier
There are numbers in the 'VTR' column that appear more than once. most appear just once.
I'd like the macro to delete all rows where the number in the 'VTR' column appears only once.(in the case of one of these numbers appearing more than once, the difference lies at the 'AFTARTKRZ' column where the value can either be (GAPNK or GAPN2) or RSLNV or RSVNK. (GAPNK or GAPN2 are the same thing)
i.e a row can appear either once with AFTARTKRZ,
(GAPNK or GAPN2)
-OR twice
either (GAPNKorGAPN2), RSLNV
or (GAPNKorGAPN2), RSVNK
OR thrice
(GAPNK or GAPN2), RSLNV, RSVNK.
I'd like to delete all those that appear only once (GAPNKorGAPN2)
Furthermore, I'd like to then add the values of the 'AFTARTKRZ' values of the duplicates to 2 extra columns at the end.
i.e, when a (GAPNK or GAPN2) appears two or threee other times, I'd like to input the 'AFTARTKRZ' column value in the 2 last columns at the end.
Something like this should be the final result
VTR|AFTARTKRZ | Add1 | Add2
11 |GAPNK |RSLNV | RSVNK| - VTR appeared thrice
12 |GAPN2 |RSLNV | | - Appeared twice as (GAPNKorGAPN2), RSLNV
13 |GAPNK |RSVNK | | - Appeared twice as (GAPNKorGAPN2), RSVNK
14 |GAPN2 | |
15 |GAPNK | |
16 |GAPN2 | |
The relevant part begins at '~~~~ Work on A
Sub Test()
Dim wb As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim RowsToTestC As Range, Delrange As Range
Dim i As Long, Lrow As Long, Lop As Long
Set ws1 = ThisWorkbook.Worksheets(1)
ThisWorkbook.ActiveSheet.Name = "A"
ws1.Copy ThisWorkbook.Sheets(Sheets.Count)
ThisWorkbook.ActiveSheet.Name = "B"
Set ws2 = ThisWorkbook.Worksheets(2)
ws1.Copy ThisWorkbook.Sheets(Sheets.Count)
ThisWorkbook.ActiveSheet.Name = "C"
Set ws2 = ThisWorkbook.Worksheets(3)
'~~~~ Work on C
Worksheets("C").Activate
With ActiveSheet
ActiveSheet.Range("A:AQ").RemoveDuplicates Columns:=6, Header:=xlNo
End With
Worksheets("C").Activate
Application.ScreenUpdating = False
'~~> Delete all but RSV
For Lrow = Range("D" & Rows.Count).End(xlUp).Row To 2 Step -1
If Range("D" & Lrow).Value = "GAPNK" Or Range("D" & Lrow) = "GAPN2" Then
Rows(Lrow).EntireRow.Delete
End If
Next Lrow
'~~~~ Work on B
Worksheets("B").Activate
With ActiveSheet
ActiveSheet.Range("A:AQ").RemoveDuplicates Columns:=6, Header:=xlNo
End With
Worksheets("B").Activate
Application.ScreenUpdating = False
'~~> Delete all but GAP
For Lrow = Range("D" & Rows.Count).End(xlUp).Row To 2 Step -1
If Range("D" & Lrow).Value = "RSVNK" Or Range("D" & Lrow) = "RSLNV" Then
Rows(Lrow).EntireRow.Delete
End If
Next Lrow
'~~~~ Work on A
Worksheets("A").Activate
Range("AR1").Select
ActiveCell.FormulaR1C1 = "RSVNK"
Range("AS1").Select
ActiveCell.FormulaR1C1 = "RSLNV"
With ws1
'~~> Get the last row which has data in Col A
Lop = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Loop through the rows
For i = 2 To Lop
'~~> For for multiple occurances
If .Cells(i, 6).Value <> "" And .Cells(i, 4).Value <> "" Then
If Application.WorksheetFunction.CountIf(.Columns(6), .Cells(i, 6)) = 1 And _
Application.WorksheetFunction.CountIf(.Columns(4), .Cells(i, 4)) = 1 Then
'~~> Store thee row in a temp range
If Delrange Is Nothing Then
Set Delrange = .Rows(i)
Else
Set Delrange = Union(Delrange, .Rows(i))
End If
End If
End If
Next
End With
End Sub
The logic of your code isn't valid.
The condition If Application.WorksheetFunction.CountIf(.Columns(4), .Cells(i, 4)) = 1 will always be False because this is the column containing your AFTARTKRZ keys. I don't know how many rows of data you have, but even in the 10 row sample you gave us the result is always greater than 1.
I do think you're making this unnecessarily complicated. Aren't you just trying to populate two lists: one of GAPs and the other of RSVs? You then want to create a third list where the GAP entries have corresponding RSV entries?
That could be done in a couple of short routines. You could do away with all of your sheet copying and row deleting and simply write your three lists directly to your sheets.
The code below shows you how this could be done. I've created 4 sheets, so you may need to add another to your Workbook: Sheet1 is your summary list (A), Sheet2 is your GAP list (B), Sheet3 is your RSV list (C), and Sheet4 holds the raw data.
Hopefully this code can get you started:
Option Explicit
Public Sub RunMe()
Const AFTARTKRZ_COL As Long = 4
Const VTR_COL As Long = 6
Dim data As Variant
Dim GAPs As Collection
Dim RSVs As Collection
Dim multis As Collection
Dim vtrKey As String
Dim multi(0 To 1) As Long
Dim i As Long, r As Long, c As Long
Dim v As Variant
Dim countRSV As Long
Dim output() As Variant
'Name your sheets.
'If you have fewer than 3 sheets or
'sheets already names A, B, C then this
'will throw an error.
Sheet1.Name = "A"
Sheet2.Name = "B"
Sheet3.Name = "C"
'Initialise the 3 collections
Set GAPs = New Collection
Set RSVs = New Collection
Set multis = New Collection
'Read the data - I've put my dummy data on Sheet4
data = Sheet4.UsedRange.Value2
'Iterate rows and place row in relevant collection
For r = 1 To UBound(data, 1)
vtrKey = CStr(data(r, VTR_COL))
On Error Resume Next 'removes duplicate entries
Select Case data(r, AFTARTKRZ_COL)
Case Is = "GAPNK", "GAPN2": GAPs.Add r, vtrKey
Case Is = "RSLNV": RSVs.Add r, vtrKey & "|RSLNV"
Case Is = "RSVNK": RSVs.Add r, vtrKey & "|RSVNK"
End Select
On Error GoTo 0
Next
'Check if each GAP also has RSVs
For Each v In GAPs
vtrKey = CStr(data(v, VTR_COL))
countRSV = 0
If Exists(RSVs, vtrKey & "|RSLNV") Then countRSV = countRSV + 1
If Exists(RSVs, vtrKey & "|RSVNK") Then countRSV = countRSV + 2
If countRSV > 0 Then
multi(0) = CLng(v)
multi(1) = countRSV
multis.Add multi, vtrKey
End If
Next
'Write your outputs
'Sheet C
ReDim output(1 To RSVs.Count + 1, 1 To UBound(data, 2))
For c = 1 To UBound(data, 2)
output(1, c) = data(1, c)
Next
i = 2
For Each v In RSVs
For c = 1 To UBound(data, 2)
output(i, c) = data(v, c)
Next
i = i + 1
Next
With Sheet3
.Cells.Clear
.Range("A1").Resize(UBound(output, 1), UBound(output, 2)).Value = output
.Columns.AutoFit
End With
'Sheet B
ReDim output(1 To GAPs.Count + 1, 1 To UBound(data, 2))
For c = 1 To UBound(data, 2)
output(1, c) = data(1, c)
Next
i = 2
For Each v In GAPs
For c = 1 To UBound(data, 2)
output(i, c) = data(v, c)
Next
i = i + 1
Next
With Sheet2
.Cells.Clear
.Range("A1").Resize(UBound(output, 1), UBound(output, 2)).Value = output
.Columns.AutoFit
End With
'Sheet A
ReDim output(1 To multis.Count + 1, 1 To 5)
output(1, 1) = "VTR"
output(1, 2) = "AFTARTKRZ"
output(1, 3) = "Add1"
output(1, 4) = "Add2"
i = 2
For Each v In multis
r = v(0)
output(i, 1) = data(r, VTR_COL)
output(i, 2) = data(r, AFTARTKRZ_COL)
output(i, 2) = data(r, AFTARTKRZ_COL)
Select Case v(1)
Case 1
output(i, 3) = "RSLNV"
output(i, 5) = "Appeared twice as (GAPNK or GAPN2), RSLNV"
Case 2
output(i, 3) = "RSVNK"
output(i, 5) = "Appeared twice as (GAPNK or GAPN2), RSVNK"
Case 3
output(i, 3) = "RSLNV"
output(i, 4) = "RSVNK"
output(i, 5) = "VTR appeared thrice"
End Select
i = i + 1
Next
With Sheet1
.Cells.Clear
.Range("A1").Resize(UBound(output, 1), UBound(output, 2)).Value = output
.Columns.AutoFit
End With
End Sub
Private Function Exists(col As Collection, key As String) As Boolean
Dim v As Variant
On Error Resume Next
v = col(key)
On Error GoTo 0
Exists = Not IsEmpty(v)
End Function
The below is my code. I have tried many different solutions but none seem to work. Any help would be appreciated.
Sub MultiDimensiionArray1()
'array for sheet one and sheet two
Dim myArraySheet1(0 To 3, 0 To 4) As Variant
Dim myArraySheet2(0 To 5, 0 To 4) As Variant
Dim i As Long, j As Long ' dimension counter for for sheet one
Dim Dimension1 As Long, Dimension2 As Long ' dimension counter for for sheet one
'number of rows in sheet one
Dim x As Integer, NumRows As Integer
Sheet1.Activate
NumRows = Range("B2", Range("B2").End(xlDown)).Rows.Count
'store everything on sheet one in array
For i = LBound(myArraySheet1, 1) To UBound(myArraySheet1, 1)
For j = LBound(myArraySheet1, 2) To UBound(myArraySheet1, 2)
myArraySheet1(i, j) = Range("A2").Offset(i, j).Value
Next j
Next i
'store everything on sheet two in array
Sheet2.Activate
For Dimension1 = LBound(myArraySheet2, 1) To UBound(myArraySheet2, 1)
For Dimension2 = LBound(myArraySheet2, 2) To UBound(myArraySheet2, 2)
myArraySheet2(Dimension1, Dimension2) = Range("A2").Offset(Dimension1, Dimension2).Value
Next Dimension2
Next Dimension1
'READ FROM ARRAY/OR DISPLAY THE RESULT
Sheet1.Activate
' Select sheet one cell G2
Range("G2").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
For i = LBound(myArraySheet1, 1) To UBound(myArraySheet1, 1)
For j = LBound(myArraySheet1, 2) To UBound(myArraySheet1, 2)
For Dimension1 = LBound(myArraySheet2, 1) To UBound(myArraySheet2, 1)
For Dimension2 = LBound(myArraySheet2, 2) To UBound(myArraySheet2, 2)
'if sheet one row equal to sheet two row execute the below code
If myArraySheet1(i, j) = myArraySheet2(Dimension1, Dimension2) Then
ActiveCell.Value = "YES IT IS DUPE AND NOT RESOLVED"
ActiveCell.Interior.ColorIndex = 4
ActiveCell.Font.ColorIndex = 2
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Value = "Brand New"
ActiveCell.Interior.ColorIndex = 3
ActiveCell.Font.ColorIndex = 2
End If
Next Dimension2
Next Dimension1
Next j
Next i
Next
End Sub
I did not use array but the code below give you the expected output that you want:
Option Explicit
Sub Compare()
Dim wb As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim Lastrow As Long, Lastrow2 As Long
Dim i As Integer, j As Integer, c As Integer
Dim FOUND As Boolean
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("Sheet1")
Set ws2 = wb.Sheets("Sheet2")
Lastrow = ws1.Range("A" & Rows.Count).End(xlUp).Row
Lastrow2 = ws2.Range("A" & Rows.Count).End(xlUp).Row
i = 2
Do
FOUND = False
For j = 2 To Lastrow2
For c = 1 To 5
If ws1.Cells(i, c).Value = ws2.Cells(j, c).Value Then
FOUND = True
Else
FOUND = False
Exit For
End If
Next c
If FOUND = True Then
ws1.Cells(i, 7) = "YES IT IS DUPE AND NOT RESOLVED"
Exit For
End If
Next j
If FOUND = False Then
ws1.Cells(i, 7) = "Brand new"
End If
i = i + 1
Loop While i < Lastrow + 1
End Sub
With this you'll have two arrays containing values of cells that aren't equal so you'll be able to use the values you need to do what you want
Sub Test()
Dim DiffSh1() As Variant
Dim DiffSh2() As Variant
Call Compare_Sheets(ThisWorkbook.Sheets("Sheet1"), ThisWorkbook.Sheets("Sheet2"), DiffSh1, DiffSh2)
'Now you can use the values in the two arrays as you need
For x = LBound(DiffSh1, 1) To UBound(DiffSh1, 1)
For y = LBound(DiffSh1, 2) To UBound(DiffSh1, 2)
If DiffSh1(x, y) <> "" Then
MsgBox ("Cell at Row " & x & " Column " & y & " isn't equal:" & vbCrLf & _
"Value in sheet1 is: " & DiffSh1(x, y) & vbCrLf & _
"Value in sheet2 is: " & DiffSh2(x, y))
End If
Next y
Next x
End Sub
Public Sub Compare_Sheets(ByVal Sh1 As Worksheet, ByVal Sh2 As Worksheet, ByRef DiffIn1() As Variant, ByRef DiffIn2() As Variant)
Dim LastCol
Dim LastRow
LastCol = Sh1.Cells(1, 1).SpecialCells(xlLastCell).Column
If Sh2.Cells(1, 1).SpecialCells(xlLastCell).Column > LastCol Then
LastCol = Sh2.Cells(1, 1).SpecialCells(xlLastCell).Column
End If
LastRow = Sh1.Cells(1, 1).SpecialCells(xlLastCell).Row
If Sh2.Cells(1, 1).SpecialCells(xlLastCell).Row > LastRow Then
LastRow = Sh2.Cells(1, 1).SpecialCells(xlLastCell).Row
End If
ReDim DiffIn1(1 To LastRow, 1 To LastCol)
ReDim DiffIn2(1 To LastRow, 1 To LastCol)
Dim mCol As Long, mRow As Long
For mCol = 1 To LastCol
For mRow = 1 To LastRow
If Sh1.Cells(mRow, mCol) <> Sh2.Cells(mRow, mCol) Then
DiffIn1(mRow, mCol) = Sh1.Cells(mRow, mCol).Value
DiffIn2(mRow, mCol) = Sh2.Cells(mRow, mCol).Value
Else
DiffIn1(mRow, mCol) = ""
DiffIn2(mRow, mCol) = ""
End If
Next mRow
Next mCol
End Sub