I have an array loading column references from column C.
The user will enter the current month, e.g. March, then the array should load February column value "U" and January value "L", then the rest of my code will run.
How do I setup the array to stop after the value "L" is found?
Sub CopyData() 'with array
Dim wb1 As Workbook
Dim wkshtname As String
Dim colArray(1 To 5) As Variant
Dim i As Range, rng As Range
Dim lrow As Long, colcounter As Long, y As Long, retcol As Long, z As Long
Dim StartHere As String, x As String, col As String
Dim cell
Dim sht As Worksheet
Set wb1 = ThisWorkbook
wkshtname = "Retro-" & wb1.Sheets("Instructions").Range("B4").Value
StartHere = wb1.Sheets("Instructions").Range("B4")
lrow = wb1.Sheets("Member Prem.Pymts").Cells(Rows.Count, 1).End(xlUp).Row
If StartHere = "January" Then
MsgBox "No Retro Commissions to be posted", vbOKOnly
Exit Sub
End If
'delete sheet if it exists
For Each sht In wb1.Worksheets
If sht.Name = wkshtname Then
Application.DisplayAlerts = False
wb1.Sheets(wkshtname).Delete
Application.DisplayAlerts = True
End If
Next sht
With wb1
.Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = wkshtname
With .Sheets(wkshtname)
.Cells(1).Resize(1, 8).Value = Array("ID", "Last Name", "First Name", "Premium", "Commission Amt", "month for", "agent", "sheet row")
End With
'returns Paid in Month 30-150 day columns
col = Application.WorksheetFunction.Match(StartHere, wb1.Sheets("Lookups").Range("$A$1:$A$13"), 0)
z = 1
For retcol = 1 To 5
colArray(retcol) = wb1.Sheets("Lookups").Cells(col - z, 3)
z = z + 1
Next retcol
With .Sheets("Member Prem.Pymts") 'reference target sheet
y = 1
For colcounter = LBound(colArray, 1) To UBound(colArray, 1)
x = 4 'starting row number data is found on
For Each i In .Range(colArray(colcounter) & "4:" & colArray(colcounter) & lrow) 'loop through Member Prem.Payments column cells
If i.Value = StartHere Then
wb1.Sheets(wkshtname).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = .Range("A" & x)
wb1.Sheets(wkshtname).Cells(Rows.Count, "B").End(xlUp).Offset(1, 0) = .Range("B" & x)
wb1.Sheets(wkshtname).Cells(Rows.Count, "C").End(xlUp).Offset(1, 0) = .Range("C" & x)
wb1.Sheets(wkshtname).Cells(Rows.Count, "D").End(xlUp).Offset(1, 0) = .Range("BR" & x)
wb1.Sheets(wkshtname).Cells(Rows.Count, "E").End(xlUp).Offset(1, 0) = wb1.Sheets("Commissions to Pay").Range(wb1.Sheets("Lookups").Cells(col - y, 4) & x)
wb1.Sheets(wkshtname).Cells(Rows.Count, "F").End(xlUp).Offset(1, 0) = .Range(colArray(colcounter) & "2")
wb1.Sheets(wkshtname).Cells(Rows.Count, "G").End(xlUp).Offset(1, 0) = .Range("DR" & x)
wb1.Sheets(wkshtname).Cells(Rows.Count, "H").End(xlUp).Offset(1, 0) = x
End If
x = x + 1
Next
y = y + 1
Next colcounter
End With
End Sub
This is what is stored in the array when I run the code.
I'm trying to load the array and then the array needs to stop loading after the value is "L".
The array will never have more than 5 elements.
EDIT: Stripped down to the core problem for testing
Sub CopyData()
Dim rngMonths As Range, c As Range, wb1
Dim colArray(), StartHere, col, retcol As Long
Set wb1 = ActiveWorkbook
Set rngMonths = wb1.Sheets("Lookups").Range("A2:A13") 'month lookup range
StartHere = "March" 'for testing
col = Application.Match(StartHere, rngMonths, 0)
If Not IsError(col) Then
Set c = rngMonths.Cells(col)
ReDim colArray(1 To 5) '<<<<<<<<<<<<
For retcol = 1 To 5
colArray(retcol) = c.Offset(0, 2).Value 'col C value
If colArray(retcol) = "L" Then Exit For 'exit if Col C="L"
Set c = c.Offset(-1) 'next cell up
Next retcol
ReDim Preserve colArray(1 To retcol) '<<<<<resize array
Debug.Print Join(colArray, ",")
Else
MsgBox "No month match!", vbExclamation
Exit Sub
End If
End Sub
Related
I'm trying to create a loop on the below code so if there are multiple matches of Column A to Column B it continue to fill out column B with the data from column A.
I've been suggested to create variant arrays and loop arrays, but I'm not that advanced yet after looking into it. Thanks.
Sub Test_match_fill_data()
Dim aCell
Dim e, k As Long, matchrow As Long
Dim w1, w2 As Worksheet
Dim cell As Range
Set w1 = Workbooks("Book1").Sheets("Sheet1")
Set w2 = Workbooks("Book2").Sheets("Sheet2")
e = w1.Cells(w1.Rows.Count, 1).End(xlUp).Row
k = w2.Cells(w2.Rows.Count, 1).End(xlUp).Row
For Each aCell In w1.Range("A2:A" & e)
On Error Resume Next
matchrow = w2.Columns("A:A").Find(What:=Left$(aCell.Value, 6) & "*", LookAt:=xlWhole).Row
On Error GoTo 0
If matchrow = 0 Then
Else
w2.Range("B" & matchrow).Value = aCell.Offset(0, 1).Value
End If
matchrow = 0
Next
End Sub
Your code would work if you searched Book1 for values from Book2. Here is an array version.
Option Explicit
Sub Test_match_fill_data()
Dim w1 As Worksheet, w2 As Worksheet
Dim ar1, ar2, matchrow, n As Long
Dim lastRow As Long, i As Long, s As String
Set w1 = Workbooks("Book1").Sheets("Sheet1")
With w1
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
ar1 = .Range("A2:B" & lastRow).Value2
End With
Set w2 = Workbooks("Book2").Sheets("Sheet2")
With w2
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
ar2 = .Range("A2:B" & lastRow).Value2
End With
For i = 1 To UBound(ar2)
s = Left(ar2(i, 1), 6)
If Len(s) > 0 Then
matchrow = Application.Match(s & "*", Application.Index(ar1, 0, 1), 0)
'Debug.Print i, s, matchrow
If Not IsError(matchrow) Then
ar2(i, 2) = ar1(matchrow, 2)
n = n + 1
End If
End If
Next
' copy array back to sheet
w2.Range("A2:B" & UBound(ar2) + 1) = ar2
MsgBox n & " rows updated"
End Sub
You can use the INDEX/MATCH formula - and then replace the results by values - no need for an array etc.
I put my assumptions in the code
Sub insertConsultants()
Dim wb1 As Workbook
Set wb1 = Workbooks("wb1.xlsx")
Dim rgDataSource As Range
'Assumption: Make = column A - first value in A3
'maybe you have to adjust this to your needs
'CurrentRegion: no empty rows within in data area
Set rgDataSource = wb1.Worksheets(1).Range("A3").CurrentRegion
Dim wb2 As Workbook: Set wb2 = Workbooks("wb2.xlsx")
Dim rgTarget As Range
'Assumption: Make = column A - first value in A3
'maybe you have to adjust this to your needs
Set rgTarget = wb2.Sheets(1).Range("A3").CurrentRegion
With rgTarget .Offset(, 1).Resize(, 1)
' = consultants column
.Formula = "=INDEX(" & rgDataSource.Columns(2).Address(True, True, , True) & ",MATCH(A3," & rgDataSource.Columns(1).Address(True, True, , True) & ",0))"
.Value = .Value
End With
End Sub
IMPORTANT: you always have to define each variable indivdually:
With your code Dim w1, w2 As Worksheet w1 is a variant not a worksheet. This could lead to errors.
I have many tables that need data combined. I have combined some of the tables into a test table to test the code. I am sorting the unique values in column 'B' a-z before running my code. It is very slow with only ~3500 records. The actual total is over 100,000 records. I'm curious to see if I can load the whole table to an array and perform the same functions, but I'm not sure if it is possible.
My table structure is:
Unique ID
First
Last
Company
etc.
A1
John
A1
Doe
A1
company1
A2
Jay
Varnado
A3
Joe
Snuffy
A3
M.
company2
The desired outcome is:
Unique ID
First
Last
Company
etc.
A1
John
Doe
company1
A1
John
Doe
company1
A1
John
Doe
company1
A2
Jay
Varnado
A3
Joe M.
Snuffy
company2
A3
Joe M.
Snuffy
company2
Dim cel As Range, rng As Range, r As Range
Dim arr(14) As String, temp As String
Dim i As Long, b As Long, j As Long, lRow As Long, lRec As Long, c As Long
Dim ii As Integer, v As Integer, col As Integer
Dim dict As Scripting.Dictionary
Dim str() As String
Dim BenchMark As Double
BenchMark = Timer
lRow = Sheet3.Cells(Rows.Count, 1).End(xlUp).Row
For c = 3 To lRow
Debug.Print c
Set cel = Sheet3.Range("B" & c)
If Trim(cel.Offset(1, 0)) = Trim(cel.Value) Then
'Determine range of like keys
i = 1
Do Until cel.Offset(i, 0).Value <> cel.Value
i = i + 1
Loop
lRec = cel.Offset(i, 0).Row - 1
'Compare data
For i = 3 To 16
ii = i - 3
'Create rng and loop through each column
Set rng = Sheet3.Range(Sheet3.Cells(c, i), Sheet3.Cells(lRec, i))
Set dict = New Scripting.Dictionary 'CreateObject("Scripting.Dictionary")
For Each r In rng
If dict.Exists(r.Value) = False And Len(r.Value) > 0 Then
dict.Add r.Value, r.Value
End If
Next r
'Add to string array
'Debug.Print Split(Join(dict.Keys, "|"), "|")
str = Split(Join(dict.Keys, ","), ",")
arr(ii) = Join(str, ",")
Set dict = Nothing
Next i
'Set range equal to array
For j = cel.Row To lRec
v = 0
For col = 3 To 16
Sheet3.Cells(j, col) = arr(v)
Sheet3.Cells(j, col) = arr(v)
v = v + 1
Next col
Next j
'Go to last cell in range
c = lRec
Else: GoTo NextCel
End If
'Clear array
NextCel:
On Error Resume Next
'Debug.Print Join(arr, ",")
Erase arr
On Error GoTo 0
Next c
MsgBox ("Done in " & Timer - BenchMark)
End Sub
Assuming ID is in column B and output as single lines per ID to Sheet1 or with duplicates to Sheet2.
Option Explicit
Sub Process()
Dim dict As Object, key
Dim iLastRow As Long, n As Long, r As Long
Dim c As Integer, s As String
Dim arIn, arOut, t0 As Single: t0 = Timer
Set dict = CreateObject("Scripting.Dictionary")
iLastRow = Sheet3.Cells(Rows.Count, "B").End(xlUp).Row
arIn = Sheet3.Range("A1").Resize(iLastRow, 16).Value2
n = 0
' determine number of unique ids
For r = 3 To iLastRow
key = Trim(arIn(r, 2))
If Len(key) > 0 Then
If Not dict.exists(key) Then
n = n + 1
dict.Add key, n
End If
End If
Next
' dimension output array and fill
ReDim arOut(1 To n, 1 To 15)
For r = 3 To iLastRow
key = Trim(arIn(r, 2))
n = dict(key)
arOut(n, 1) = key
' concat columns
For c = 3 To 16
s = Trim(arIn(r, c))
If Len(s) > 0 Then
arOut(n, c - 1) = arOut(n, c - 1) & " " & s
End If
Next
Next
' output to sheet1
Sheet1.Range("A1").Resize(n, 15) = arOut
MsgBox "Done in " & Format(Timer - t0, "0.0 secs")
' or with duplicates to sheet2
For r = 3 To iLastRow
key = Trim(arIn(r, 2))
n = dict(key)
Sheet2.Cells(r, 2) = key
For c = 3 To 16
Sheet2.Cells(r, c) = arOut(n, c - 1)
Next
Next
End Sub
This assumes the data is on Sheet1 starting in A1.
Not sure how efficient it is.
Option Explicit
Sub Test()
Dim rngDst As Range
Dim dicIDs As Object
Dim dicData As Object
Dim arrData As Variant
Dim arrCols As Variant
Dim idxRow As Long
Dim idxCol As Long
Dim ky As Variant
Dim fld As Variant
Dim cnt As Long
With Sheets("Sheet1").Range("A1").CurrentRegion
arrCols = .Rows(1).Value
arrData = .Offset(1).Resize(.Rows.Count - 1).Value
End With
Set dicIDs = CreateObject("Scripting.Dictionary")
For idxRow = LBound(arrData, 1) To UBound(arrData, 1)
ky = arrData(idxRow, 1)
If dicIDs.exists(ky) Then
Set dicData = dicIDs(ky)
cnt = cnt + 1
Else
Set dicData = CreateBlankDic(arrCols)
End If
For idxCol = LBound(arrData, 2) To UBound(arrData, 2)
fld = arrCols(1, idxCol)
If arrData(idxRow, idxCol) <> "" Then
dicData(fld) = arrData(idxRow, idxCol)
End If
Next idxCol
Set dicIDs(ky) = dicData
Next idxRow
Set rngDst = Sheets("Sheet1").Range("A1").Offset(, UBound(arrCols, 2) + 2)
rngDst.Resize(1, UBound(arrCols, 2)).Value = arrCols
Set rngDst = rngDst.Offset(1).Resize(cnt, UBound(arrCols, 2))
ReDim arrData(1 To cnt, 1 To UBound(arrCols, 2))
cnt = 1
For Each ky In dicIDs.keys
Set dicData = dicIDs(ky)
idxCol = 1
For Each fld In dicData.keys
arrData(cnt, idxCol) = dicData(fld)
idxCol = idxCol + 1
Next fld
cnt = cnt + 1
Next ky
rngDst.Value = arrData
End Sub
Function CreateBlankDic(arrKeys, Optional BlankVal = "") As Object
Dim dic As Object
Dim idxCol As Long
Set dic = CreateObject("Scripting.Dictionary")
For idxCol = LBound(arrKeys, 2) To UBound(arrKeys, 2)
dic(arrKeys(1, idxCol)) = BlankVal
Next idxCol
Set CreateBlankDic = dic
End Function
I am trying to work through a code that utilizes a system to check two different worksheets by using a for loop and highlight the differences/edits made in the second sheet ("Version 2") onto the first sheet ("Original"). I have a feeling that I need to utilize an array but I'm not advanced enough where I know how to store the values and then later write them onto another sheet (down below).
I've gotten the code so that it highlights all the relevant cells, but now I'm trying to output it into a report (on another sheet called 'Logged Changes') which will summarize all the cell addresses where edits were made. Please forgive all the variables as this is from an old code set where variables are not explicitly defined:
Private Sub CompareBasic()
Dim actSheet As Range
Dim k As Integer
Dim o As Long
Dim p As Long
Dim i As Integer
Dim change As Integer
o = Worksheets("Original").Cells(2, Columns.Count).End(xlToLeft).Column
p = Worksheets("Original").Range("A" & Rows.Count).End(xlUp).Row
change = 0
Sheets("Original").Select
For i = 2 To p
For k = 1 To o
If IsNumeric(Worksheets("Original").Cells(i, k).Value) = True Then
If Worksheets("Original").Cells(i, k).Value <> Worksheets("Version 2").Cells(i, k).Value Then
Worksheets("Original").Cells(i, k).Interior.ColorIndex = 37
change = change + 1
End If
Else
If StrComp(Worksheets("Original").Cells(i, k), Worksheets("Version 2").Cells(i, k), vbBinaryCompare) <> 0 Then
Worksheets("Original").Cells(i, k).Interior.ColorIndex = 37
change = change + 1
End If
End If
Next k
Next i
Unload Me
MsgBox "Number of cells edited counted: " & change, vbOKOnly + vbExclamation, "Summary"
b = Empty
answer = MsgBox("Do you want to run the Report?", vbYesNo + vbQuestion)
If answer = vbYes Then
If Sheet_Exists("Logged Changes") = False Then
Sheet_Name = "Logged Changes"
Worksheets.Add(After:=Sheets(Sheets.Count)).Name = Sheet_Name
End If
Worksheets("Logged Changes").Range("A1") = "Edited Requirements"
Else
Unload Me
End If
End Sub
I have tried fiddling around with the code, but didn't want to clog it up with any unnecessary/broken lines. Any help would be greatly appreciated!
Try this:
Option Explicit
Private Sub CompareBasic()
Const SHT_REPORT As String = "Logged Changes"
Dim actSheet As Range
Dim c As Integer
Dim o As Long
Dim p As Long
Dim r As Long
Dim change As Long, wsOrig As Worksheet, wsNew As Worksheet, wsReport As Worksheet
Dim dataOrig, dataNew, rngData As Range, v1, v2, bDiff As Boolean
Dim arrUpdates
Set wsOrig = Worksheets("Original")
Set wsNew = Worksheets("Version 2")
o = wsOrig.Cells(2, Columns.Count).End(xlToLeft).Column
p = wsOrig.Range("A" & Rows.Count).End(xlUp).Row
Set rngData = wsOrig.Range("A2", wsOrig.Cells(p, o))
dataOrig = rngData.Value 'get an array of data
dataNew = wsNew.Range(rngData.Address).Value 'array of new data
ReDim arrUpdates(1 To rngData.Cells.Count, 1 To 3) 'for change info
change = 0
For r = 1 To UBound(dataOrig, 1)
For c = 1 To UBound(dataOrig, 2)
v1 = dataOrig(r, c)
v2 = dataNew(r, c)
If Len(v1) > 0 Or Len(v2) > 0 Then
If IsNumeric(v1) Then
bDiff = v1 <> v2
Else
bDiff = StrComp(v1, v2, vbBinaryCompare) <> 0
End If
End If
'any difference?
If bDiff Then
change = change + 1
With rngData.Cells(r, c)
arrUpdates(change, 1) = .Address
.Interior.ColorIndex = 37
End With
arrUpdates(change, 2) = v1
arrUpdates(change, 3) = v2
End If
Next c
Next r
If MsgBox("Do you want to run the Report?", vbYesNo + vbQuestion) = vbYes Then
With GetSheet(SHT_REPORT, ThisWorkbook)
.UsedRange.ClearContents
.Range("A1") = "Edited Requirements"
.Range("A3").Resize(1, 3).Value = Array("Address", wsOrig.Name, wsNew.Name)
.Range("A4").Resize(change, 3).Value = arrUpdates
End With
Else
'Unload Me
End If
End Sub
'return as sheet from wb by name (and create it if it doesn't exist)
Function GetSheet(wsName, wb As Workbook) As Worksheet
Dim rv As Worksheet
On Error Resume Next
Set rv = wb.Worksheets(wsName)
On Error GoTo 0
If rv Is Nothing Then
Set rv = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
rv.Name = "Logged Changes"
End If
Set GetSheet = rv
End Function
Sheet Differences
Option Explicit
Sub logChanges()
Const ws1Name As String = "Original"
Const ws2Name As String = "Version 2"
Const wsResult As String = "Logged Changes"
Const FirstRow As Long = 2
Const FirstColumn As Long = 1
Const LastRowColumn As Long = 1
Const LastColumnRow As Long = 2
Const ResultFirstCell As String = "A2"
Dim Headers As Variant
Headers = Array("Id", "Address", "Original", "Version 2")
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(ws1Name)
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, LastRowColumn).End(xlUp).Row
Dim LastColumn As Long
LastColumn = ws.Cells(LastColumnRow, ws.Columns.Count) _
.End(xlToLeft).Column
Dim rng As Range
Set rng = ws.Range(ws.Cells(FirstRow, FirstColumn), _
ws.Cells(LastRow, LastColumn))
Dim Data1 As Variant: Data1 = rng.Value
Set ws = wb.Worksheets(ws2Name)
Dim Data2 As Variant: Data2 = ws.Range(rng.Address).Value
Dim Result() As Variant
Dim i As Long, j As Long, k As Long
For i = 1 To UBound(Data1)
For j = 1 To UBound(Data1, 2)
If Data1(i, j) <> Data2(i, j) Then GoSub writeResult
Next j
Next i
If k > 0 Then
transpose2D Result
On Error GoTo MissingResultSheet
Set ws = wb.Worksheets(wsResult)
On Error GoTo 0
ws.Range(ws.Range(ResultFirstCell), _
ws.Cells(ws.Rows.Count, ws.Columns.Count)).Clear
ws.Range(ResultFirstCell).Resize(k, UBound(Result, 2)).Value = Result
MsgBox "Found '" & k & "' difference(s) in range '" _
& rng.Address(False, False) & "'.", vbInformation
Else
MsgBox "Found no differences in range '" _
& rng.Address(False, False) & "'.", vbExclamation
End If
Exit Sub
writeResult:
k = k + 1
ReDim Preserve Result(1 To 4, 1 To k)
Result(1, k) = k
Result(2, k) = getAddress(i + FirstRow - 1, j + FirstColumn - 1)
Result(3, k) = Data1(i, j)
Result(4, k) = Data2(i, j)
Return
MissingResultSheet:
If Err.Number = 9 Then
wb.Worksheets.Add After:=wb.Sheets(wb.Sheets.Count)
With ActiveSheet
.Name = wsResult
If .Range(ResultFirstCell).Row > 1 Then
.Range(ResultFirstCell).Offset(-1) _
.Resize(, UBound(Headers) + 1).Value = Headers
End If
End With
Resume ' i.e. the code continues with Set ws = wb.Worksheets(wsResult)
Else
'?
Exit Sub
End If
End Sub
Function getAddress(aRow As Long, aColumn As Long) As String
getAddress = ActiveSheet.Cells(aRow, aColumn).Address(False, False)
End Function
Sub transpose2D(ByRef Data As Variant)
Dim i As Long, j As Long
Dim Result As Variant
ReDim Result(LBound(Data, 2) To UBound(Data, 2), _
LBound(Data) To UBound(Data))
For i = LBound(Data) To UBound(Data)
For j = LBound(Data, 2) To UBound(Data, 2)
Result(j, i) = Data(i, j)
Next j
Next i
Data = Result
End Sub
This solution for converting a column number to a string without using objects Function to convert column number to letter? could be used to write a descent getAddress function.
I keep getting a runtime Error 424 when I try to access arrayCount.Length. I think this might have to do with the fact that arrayCount was declared as a Public Variant. How do I resolve this bug?
' Initialize variables
Private counter As Integer
Private Account As String
Private chartSize As Integer
Public arrayCount As Variant
Public arrayAccounts As Variant
' Iterate over each entry row, determining the corresponding Account
Sub RowInsert()
' Initialize ArrayCount with starting values of -1
arrayCount = Array(-1, -1, -1, -1, -1, -1, -1, -1, -1)
arrayAccounts = Array("Cash", "Equipment", "Prepaid Rent", "Inventory", "Marketable Securities", "Accounts Recievable", "Accounts Payable", "Bonds Payable", "Common Stock")
' BUG HERE
chartSize = arrayAccounts.Length
' Continued...
End Sub
'Continued...
I coerced my previous answer to use collections instead of a Dictionary and Arraylists; so that it would be Mac compatible.
Sub MacCompileData()
Application.ScreenUpdating = False
Dim lastRow As Long, x As Long
Dim data, Key
Dim r As Range
Dim cLedger As Collection, cList As Collection
Set cLedger = New Collection
With Worksheets("Journal")
lastRow = .Range("B" & .Rows.Count).End(xlUp).Row
For x = 2 To lastRow
Key = Trim(.Cells(x, 2))
On Error Resume Next
Set cList = cLedger(Key)
If Err.Number <> 0 Then
Set cList = New Collection
cLedger.Add cList, Key
End If
On Error GoTo 0
cLedger(Key).Add Array(.Cells(x, 1).Value, .Cells(x, 3).Value, .Cells(x, 4).Value)
Next
End With
With Worksheets("Ledger")
For Each r In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
If r <> "" Then
On Error Resume Next
Key = Trim(r.Text)
data = getLedgerArray(cLedger(Key))
If Err.Number = 0 Then
Set list = cLedger(Key)
x = cLedger(Key).Count
With r.Offset(2).Resize(x, 3)
.Insert Shift:=xlDown, CopyOrigin:=r.Offset(1)
.Offset(-x).Value = data
.Offset(0, 1).Resize(1, 1).FormulaR1C1 = "=""Bal. "" & TEXT(SUM(R[-" & x & "]C:R[-1]C)-SUM(R[-" & x & "]C[1]:R[-1]C[1]),""$#,###"")"
r.Offset(1).EntireRow.Delete
End With
End If
On Error GoTo 0
End If
Next
End With
Application.ScreenUpdating = True
End Sub
Function getLedgerArray(c As Collection)
Dim data
Dim x As Long
ReDim data(1 To c.Count, 1 To 3)
For x = 1 To c.Count
data(x, 1) = c(x)(0)
data(x, 2) = c(x)(1)
data(x, 3) = c(x)(2)
Next
getLedgerArray = data
End Function
As an alternate approach I compiled all the information using a Dictionary to group the data. Each key in the Dictionary has an ArrayList associated with it. Each element in the ArrayList is an 1 dimensional array of data that holds the Date, Debit and Credit information.
The Ledger is then searched for each Key in the Dictionary. If found the array that the Dictionary's ArrayList is extracted and transposed twice to convert it to a standard 2 dimensional array. The array is then inserted into worksheet.
Sub CompileData()
Application.ScreenUpdating = False
Dim x As Long
Dim Data, Key
Dim r As Range
Dim dLedger As Object, list As Object
Set dLedger = CreateObject("Scripting.Dictionary")
With Worksheets("Journal")
For x = 2 To .Range("B" & .Rows.Count).End(xlUp).Row
Key = Trim(.Cells(x, 2))
If Not dLedger.Exists(Key) Then
Set list = CreateObject("System.Collections.ArrayList")
dLedger.Add Key, list
End If
dLedger(Key).Add Array(.Cells(x, 1).Value, .Cells(x, 3).Value, .Cells(x, 4).Value)
Next
End With
With Worksheets("Ledger")
For Each Key In dLedger
Set r = Intersect(.Columns("A:C"), .UsedRange).Find(What:=Key)
If Not r Is Nothing Then
Set list = dLedger(Key)
Data = list.ToArray
Data = Application.Transpose(Data)
x = dLedger(Key).Count
With r.Offset(2).Resize(x, 3)
.Insert Shift:=xlDown, CopyOrigin:=r.Offset(1)
.Offset(-x).Value = Application.Transpose(Data)
.Offset(0, 1).Resize(1, 1).FormulaR1C1 = "=""Bal. "" & TEXT(SUM(R[-" & x & "]C:R[-1]C)-SUM(R[-" & x & "]C[1]:R[-1]C[1]),""$#,###"")"
r.Offset(1).EntireRow.Delete
End With
End If
Next
End With
Application.ScreenUpdating = True
End Sub
After a lot of googling and trying I am asking you for help regarding the following Problem.
Worksheet 1 (Database) has the ID's and a lot of Information in Column D
Worksheet 2 (Skills) has the ID's in Row 1 and all respective skills in the rows below the column for each ID.
Worksheet 3 (Output) is needed to populate Listboxes and Graphs and can be considered empty
For Illustration purposes: http://imgur.com/a/Nt88C
Via comboboxes, the skill the user is looking for is selected. This Skill then needs to be matched against the skills of each ID on Worksheet 2.
If a match is found, the respective ID shall be found on Worksheet 1 and certain Information from there copied to Worksheet 3.
My take on this has been to find each ID in Worksheet 1, match it with all ID's on Worksheet 2 and look through the respective rows for a match. However, every more efficient way is welcome.
Here my code:
The comboboxes
Dim wb As Workbook
Set wb = ActiveWorkbook
Dim ws1, ws2, ws3, ws4 As Worksheet
Set ws1 = wb.Worksheets("Meta DB")
Set ws2 = wb.Worksheets("Criteria")
Set ws3 = wb.Worksheets("Supplier Criteria TreeView")
Set ws4 = wb.Worksheets("Supplier Skills")
'1. - - get all Suppliers for the selected Input
'Redefine for clarity
Dim strFind As String
'1.0. - - Clear previously used ranges
ws3.Range("A2:L28").Clear
ws3.Range("A30:L100").Clear
ws3.Range("V2:V20").Clear
'1.1. - - Get value to search for and range to go through (depending on combobox selections)
If Me.comboProduct.ListIndex = -1 And Me.comboSubGroup.ListIndex = -1 And Me.comboCG.ListIndex <> -1 Then
strFind = Me.comboCG.value
ElseIf Me.comboProduct.ListIndex = -1 And Me.comboSubGroup.ListIndex <> -1 And Me.comboCG.ListIndex <> -1 Then
strFind = Me.comboSubGroup.value
ElseIf Me.comboProduct.ListIndex <> -1 And Me.comboSubGroup.ListIndex <> -1 And Me.comboCG.ListIndex <> -1 Then
strFind = Me.comboProduct.value
End If
Try 1:
Dim rng1, rng2 As Range
Dim lRow, j, k As Long
Dim IDrow As String
'Paste starting at row 2 or 30 in ws3, respectively (Active / Inactive)
j = 2
k = 30
For Each rng1 In ws1.Range("D4:D500")
If Rng <> "" Then
For Each rng2 In ws4.Range("A1:ZZ1")
If rng2 <> "" Then
If rng1.value = rng2.value Then
For lRow = 2 To ws4.UsedRange.Rows.Count
IDrow = ws4.Cells(lRow, rng2).value
If InStr(1, IDrow, strFind, vbTextCompare) > 0 Then
'Check for active Supplier in current Database-row
If ws1.Range("E" & rng1) = "Yes" Then
'Copy row of Database to row j of ws3 then increment j
ws1.Range("B" & rng1 & ":" & "E" & rng1).Copy Destination:=ws3.Range("B" & j & ":" & "E" & j) 'Copy Name, Potential Supplier, ID, Active
j = j + 1
'ElseIf inactive Supplier, post further down from 30 onwards. Second listbox populates from there
ElseIf ws1.Range("E" & rng1) = "No" Then
ws1.Range("B" & rng1 & ":" & "E" & rng1).Copy Destination:=ws3.Range("B" & k & ":" & "E" & k) 'Copy Name, Potential Supplier, ID, Active
k = k + 1
Else
Exit Sub
End If
End If
Next lRow
End If
End If
Next rng2
End If
Next rng1
Try 2:
Dim IDAr, MyAr, TempAr As Variant
Dim lRow, lastRow, entryrow, LCol, e As Long
Dim ColumnLetter As String
entryrow = ws3.Range("B" & Rows.Count).End(xlUp).row + 1
ws1LRow = ws1.Range("D" & ws1.Rows.Count).End(xlUp).row
IDAr = ws1.Range("D4:D" & lRow).value
Set f = ws4.Range("A1:ZZ1").Find(What:=IDAr, LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=False)
ColumnLetter = Split(f.Address, "$")(1)
lastRow = ws4.Range(ColumnLetter & "2:" & ColumnLetter & "50").End(xlUp).row
MyAr = ws4.Range(ColumnLetter & "1:" & ColumnLetter & lastRow).value
With ws3
'If IsArray(MyAr) Then
For i = LBound(MyAr) To UBound(MyAr)
TempAr = Split(MyAr(i, 1), "\")
For e = 0 To 2
TempAr(e) = ValueToCompare
If InStr(1, ValueToCompare, strFind, vbTextCompare) > 0 Then
ws3.Range("B" & entryrow).value = "Test if it works"
'.
'.
'.
End If
Next e
Next i
Thank you all in advance for any tips!
Sub CodeForLazyPoster()
Dim rIDs As Excel.Range
Dim ID As Excel.Range
Dim lFoundRow As Long
Set rIDs = Worksheets("Sheet1").Range("a1:a10")
For Each ID In rIDs
lFoundRow = FindRow(ID)
If lFoundRow > 0 Then
If FindSkill("Maths", Worksheets("Sheet2").Range("B" & lFoundRow)) Then
' Copy here
End If
End If
Next ID
End Sub
Function FindRow(strFind) As Long
FindRow = 0
On Error Resume Next
FindRow = Application.WorksheetFunction.Match( _
strFind, Worksheets("Sheet2").Range("a1:a10"), False)
End Function
Function FindSkill(strSkill As String, rngLookIn As Excel.Range) As Boolean
Dim tmp As Integer
FindSkill = False
On Error GoTo eHandle
tmp = Application.WorksheetFunction.Match(strSkill, rngLookIn, False)
FindSkill = True
Exit Function
eHandle:
End Function