Sorry if this is long. I had to explain everything.
I have the following three moduels:
1. CreateDemoMap
2. CreateDemoTable
3. Update
The CreateDemoMap will go through a table and get the location (Top and Left), size (Width and Length), Name, Rotation and title of shapes and place them on the screen. Basically, it will build a map. This is the main part of my code:
For i = 2 To endNum 'input the number manual for now
Top = Workbooks("Reference").Worksheets("Directory").Cells(i, 2)
Left = Workbooks("Reference").Worksheets("Directory").Cells(i, 3)
Width = Workbooks("Reference").Worksheets("Directory").Cells(i, 4)
Height = Workbooks("Reference").Worksheets("Directory").Cells(i, 5)
Name = Workbooks("Reference").Worksheets("Directory").Cells(i, 6)
Rotation = Workbooks("Reference").Worksheets("Directory").Cells(i, 7)
Title = Workbooks("Reference").Worksheets("Directory").Cells(i, 8)
Set sh = w.Shapes.AddShape(msoShapeRectangle, Left, Top, Width, Height)
sh.Select
Selection.ShapeRange.Fill.Visible = msoFalse
Selection.ShapeRange.Rotation = Rotation
Selection.ShapeRange.Title = Title
Selection.ShapeRange.Name = Name
Next i
Here is a screenshot of my table and the map:
Map & Table
Next, I thought it would be cool to go through the shape range array and get the properties of each objects. Also, it enabled me get the shape ID.
Sub Test1()
Dim Top As Long
Dim Left As Long
Dim Width As Long
Dim Height As Long
Dim ID As String
Dim Name As String
Dim Rotation As String
Dim Title As String
Dim sh As Object
Dim endNum As Integer
CreateSheet ("DemoTable")
totalShape = 90
rnr = 2
IndexNum = 0
Worksheets("DemoMap").Activate
For Each shp In ActiveSheet.Shapes
IndexNum = IndexNum + 1
Worksheets("DemoTable").Cells(rnr, 1) = IndexNum
Worksheets("DemoTable").Cells(rnr, 2) = shp.Top
Worksheets("DemoTable").Cells(rnr, 3) = shp.Left
Worksheets("DemoTable").Cells(rnr, 4) = shp.Width
Worksheets("DemoTable").Cells(rnr, 5) = shp.Height
Worksheets("DemoTable").Cells(rnr, 6) = shp.ID
Worksheets("DemoTable").Cells(rnr, 7) = shp.Name
Worksheets("DemoTable").Cells(rnr, 9) = shp.Rotation
Worksheets("DemoTable").Cells(rnr, 10) = shp.Title
Worksheets("DemoTable").Cells(rnr, 11) = shp.Type
rnr = rnr + 1
Next shp
End Sub
This is how it looks like:
Shape Table
Objectives:
A. update the Top, Left, and rotation of the shapes if the objects were moved or rotated.
B. Be able to account for deleted and added shapes
Solutions:
A. Since there wasn't an event listener in VBA, I decided to let the user move the objects however she want and then click a button that would update the table you saw earlier. Here is my code for this sub:
Sub UpdateShapes()
Dim Top As Long
Dim Left As Long
Dim Width As Long
Dim Height As Long
Dim ID As String
Dim Name As String
Dim Rotation As String
Dim Title As String
Dim sh As Object
Dim endNum As Integer
Dim Changes As Integer
Dim JSBChanges As Integer
Dim OneChanges As Integer
Dim TwoChanges As Integer
Dim ThreeChanges As Integer
Dim M1Changes As Integer
Dim M2Changes As Integer
Dim Deleted As Integer
Dim myDoc As Worksheet
Dim ShapeNum As Integer
Dim ShapeIndex As Integer
JSBChanges = 0
OneChanges = 0
TwoChanges = 0
ThreeChanges = 0
M1Changes = 0
M2Changes = 0
Deleted = 0
Set myDoc = Workbooks("Reference").Worksheets("DemoMap")
ShapeNum = myDoc.Shapes.Count
Debug.Print ("ShapeNum is: " & ShapeNum)
Workbooks("Reference").Worksheets("DemoMap").Activate
TableIndex = 2
ShapeIndex = 1
While (TableIndex <= (ShapeNum + 1))
Changes = 0
If(Workbooks("Reference").Worksheets("DemoTable").Cells(TableIndex, 6) = myDoc.Shapes.Range(ShapeIndex).ID) Then
If (Workbooks("Reference").Worksheets("DemoTable").Cells(TableIndex, 2) <> myDoc.Shapes.Range(ShapeIndex).Top) Then
Workbooks("Reference").Worksheets("DemoTable").Cells(TableIndex, 2) = myDoc.Shapes.Range(ShapeIndex).Top
Changes = Changes + 1
End If
If (Workbooks("Reference").Worksheets("DemoTable").Cells(TableIndex, 3) <> myDoc.Shapes.Range(ShapeIndex).Left) Then
Workbooks("Reference").Worksheets("DemoTable").Cells(TableIndex, 3) = myDoc.Shapes.Range(ShapeIndex).Left
Changes = Changes + 1
End If
If (Workbooks("Reference").Worksheets("DemoTable").Cells(TableIndex, 9) <> myDoc.Shapes.Range(ShapeIndex).Rotation) Then
Workbooks("Reference").Worksheets("DemoTable").Cells(TableIndex, 9) = myDoc.Shapes.Range(ShapeIndex).Rotation
Changes = Changes + 1
End If
If (Changes >= 1) Then
With myDoc.Shapes.Range(ShapeIndex).Line
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
End With
Select Case (myDoc.Shapes.Range(ShapeIndex).Title)
Case "JSB"
JSBChanges = JSBChanges + 1
Case "1"
OneChanges = OneChanges + 1
Case "2"
TwoChanges = TwoChanges + 1
Case "3"
ThreeChanges = ThreeChanges + 1
Case "M1"
M1Changes = M1Changes + 1
Case "M2"
M2Changes = M2Changes + 1
End Select
End If
Else
Deleted = Deleted + 1
Workbooks("Reference").Worksheets("DemoTable").Rows(TableIndex).Interior.ColorIndex = 3
Workbooks("Reference").Worksheets("DemoTable").Rows(TableIndex).Font.ColorIndex = 2
ActiveWorkbook.Save
ShapeIndex = ShapeIndex - 1
End If
TableIndex = TableIndex + 1
ShapeIndex = ShapeIndex + 1
ShapeNum = myDoc.Shapes.Count
Wend
MsgBox ("JSBChanges: " & JSBChanges)
MsgBox ("OneChanges: " & OneChanges)
MsgBox ("TwoChanges: " & TwoChanges)
MsgBox ("ThreeChanges: " & ThreeChanges)
MsgBox ("M1Changes: " & M1Changes)
MsgBox ("M2Changes: " & M2Changes)
MsgBox ("Deleted: " & Deleted)
End Sub
Let's assume no shape has been added or deleted, which means the shaperange array should have the same number of objects. Thru. trail and error, I also discovered that the array elements won't move around and will stay still if you move your objects around. So, as you see, the code will compare the elements inside the DemoTable I just created with the elements inside the shaperange array. I can verify that this works if I start move things around. It will successfully update the Top and Left properties of the shapes that have been displaced.
Problem/Challenge/Issue:
Then I expanded the code, so it would identify if a shape has been deleted. As you see in my code, the fourth row in my table (Table Index = 4) should be the same (thus have the same shape ID) as the third element in the ShapeRange array. However if the third shape is deleted, the array get shrunk, which means the third element in the new (updated automaically) shapeRange array is the fourth element in the old array. This is useful, because then you can use this to figure out if a shape has been deleted or not. If the ID associated with TabeIndex = 4 is the same as Shape Index = 3, then that means that the object described by TableIndex = 4 has been deleted and the Shape associate with Shape Index = 3 should be the same as the one referenced by Table Index = 5 (the next shape). That's why, I added ShapeIndex = ShapeIndex - 1.
Make the story short, this works sometimes, but the other times it's not accurate. Last night I deleted 20 shapes and ran the sub. It told me that 17 objects were deleted. I spend hours looking the results and debugging the code, but found nothing. This evening, I ran the code again after deleting 15 objects. Here is my updated table:
Updated Demo Table
Those red lines mean that that row (particular shape) has been deleted. In this case, I deleted 15 shapes, but it only shows that only 12 shapes have been deleted. Obviously this not right. As I said earlier, it happened last night too. It's not consistent at all. To prove this, I used a similar code as my CreateDemMap sub. Basically, it goes through each objects in the worksheet and make a table just like before. If everything would've gone right, this table should be exactly the same as my Demo Table (assuming if I delete those red rows). It's NOT!
New Table For Checking
The new table I extracted from the ShapeRange array tells me that there are 70 shapes in the array (15 were deleted which is the correct number), but in my DemoTable, only 12 rows were highlighted as red. Why is this happening? Last night, I deleted a particular shape with a specific shape ID. By doing this, I was sure that that shape object would not be in the ShapeRange Array. However, when I was debugging, I realized that wasn't the case. The object was gone from my screen, but its shape ID (and consequently the shape itself) was still in the ShapeRange Array. Why is VBA Excel acting like this? Can someone help me please?
It's really hard to understand all your code - but I think your problem is because you're ending your loop too early. It runs until ShapeNum which is the number of shapes you have in your sheet. When you delete some shapes, this number is lower than the number of entries in your table and the last entries in the table are not checked.
Related
I have the following task:
There are fields in my document, the combination of which needs to be compared, and if they are the same, another field on the same rows need to be updated.
So far, I add the values in arrays (skipping the first row as header, thus iNum = 2) with select statements per column and concatenate them per row for the comparison.
Dim conc As Range 'Concatenated fields
Dim iconc() As Variant
ReDim iconc(UBound(iMatn) - 1, 1)
For iNum = 2 To UBound(iMatn)
iconc(iNum - 1, 1) = iMatn(iNum, 1) & iVendr(iNum, 1) & iInd1(iNum, 1) & iInd2(iNum, 1) 'Current concatenation
Select Case iNum - 1
Case 2: 'Compare two records
If iconc(iNum - 2, 1) = iconc(iNum - 1, 1) Then 'Compare first and second records
'Execute code to update the two fields from Extra field column
End If
Case 3: 'Compare three records
If AllSame(iconc(iNum - 3, 1), iconc(iNum - 2, 1), iconc(iNum - 1, 1)) Then
'Execute code to update the three fields from Extra field column
End If
I go through each value of the concatenation and compare if its the same as the previous ones with Case statement (I don't expect more than 4 or 5 to be the same, even though there could be a couple hundred of lines).
Thus I face two issues:
If there are 3 equal values, for example, the code first jumps to the case for 2. How can I make it so that it skips to the maximum value?
It needs to resume checking after the rows that were already checked. E.g. if the first two are the same, the code should start checking from the third one; basically to start at from the line after the last of any duplicate ones that are located.
Example
Image: the code needs to return that there are 3 equal rows (lines 2 to 4), update the respective cells on the "Extra field" column, proceed further (from line 5), return that there are 2 equal rows (lines 6 and 7), update the same as above again, proceed further (from line 8) etc.
Any help will be highly appreciated as I am stuck with this problem.
Thank you all.
To determine how many are in each group, in order to decide how you will update the extra fields column, I would use a Dictionary & Collection object.
eg:
'Set reference to Microsoft Scripting Runtime
' (or use late-binding)
Option Explicit
Sub due()
Dim myDict As Dictionary, col As Collection
Dim i As Long, v As Variant
Dim sKey As String
Dim rTable As Range
Dim vTable As Variant, vResults As Variant
'there are more robust methods of selecting the table range
'depending on your actual layout
'And code will also make a difference if the original range includes
' or does not include the "Extra Field" Column
' Code below assumes it is NOT included in original data
Set rTable = ThisWorkbook.Worksheets("sheet2").Cells(1, 1).CurrentRegion
vTable = rTable
Set myDict = New Dictionary
For i = 2 To UBound(vTable)
sKey = vTable(i, 1) & vTable(i, 2) & vTable(i, 3) & vTable(i, 4)
Set col = New Collection
If Not myDict.Exists(sKey) Then
col.Add Item:=WorksheetFunction.Index(vTable, i, 0)
myDict.Add Key:=sKey, Item:=col
Else
myDict(sKey).Add Item:=WorksheetFunction.Index(vTable, i, 0)
End If
Next i
For Each v In myDict.Keys
Select Case myDict(v).Count
Case 2
Debug.Print v, "Do update for two rows"
Case 3
Debug.Print v, "Do update for three rows"
Case Else
Debug.Print v, "No update needed"
End Select
Next v
End Sub
=>
1234V22341212 Do update for three rows
1234v22351215 No update needed
2234v22361515 Do update for two rows
2234v22361311 No update needed
Although, I would probably use Power Query (available in Windows Excel 2010+ and 365) which can easily group by the four columns and return a count. You can then add a new column depending on that count.
Not knowing the nature of your updating Extra Field and the difference between what happens for 2, 3, 4, ... the same, it is not possible to supply any code for that purpose.
In general, you would
expand the array for each dictionary item
Add the extra column if it's not already there
Do the update
Add that to a pre-dimensioned results array
Write the results array back to the worksheet
Note that this method of working with VBA arrays will execute an order of magnitude faster than doing repeated worksheet accessing, but the code is longer.
If you use a look ahead to the next row (rather than look behind) you can determine the end of the group and process accordingly.
Option Explicit
Sub CompareRows()
Dim ws As Worksheet, ar, arExtra
Dim lastrow As Long, n As Long, i As Long, k As Long
Dim s As String, sNext As String, rng As Range, iColor As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
ar = .Range("A1:D1").Resize(lastrow)
n = 1
For i = 1 To UBound(ar)
' look ahead to next line
If i = UBound(ar) Then
sNext = ""
Else
sNext = ar(i + 1, 1) & "_" & ar(i + 1, 2) & _
"_" & ar(i + 1, 3) & "_" & ar(i + 1, 4)
End If
If i > 1 Then ' skip header
' increment count if matched
If sNext = s Then
n = n + 1
' process group using counter n
Else
If n >= 2 Then
' first row of group
Set rng = .Cells(i, "E").Offset(1 - n)
If n >= 3 Then
iColor = rgb(128, 255, 128) ' green
Else
iColor = rgb(255, 255, 128) ' yellow
End If
'code to update n rows in Extra column
rng.Resize(n).Value = n
rng.Offset(, -4).Resize(n, 5).Interior.color = iColor
k = k + 1 ' group count
End If
n = 1
End If
End If
s = sNext
Next
End With
MsgBox k & " groups found", vbInformation
End Sub
I have searched for something similar to what I am asking, and unfortunately there is nothing close to what I am looking for.
I have a unique data set here on Sheet(2): The goal is to return the values in the highlighted blue columns if it matches the same "Item#" for the box selected in a dropdown list of the box names on Sheet(1). Please see Sheet(1) here: Sheet(1) Set-Up.
The Item#'s on Sheet(1) are located in B3:B12 on Sheet(1). - I've added also another list where I would like my code to run In the column next to this is a blank where the matching items in blue would post.
I am trying to use For Loops to accomplish this. I understand that the data set is weird, but I want to keep it like that for the mere challenge of it (and also because I have a larger data set similar and am just using this as a test run)... My code so far is as follows:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
' In order to run code on sheet without a button or enabling in a module
Set KeyCells = Range("A1")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
Dim i, j As Long
Dim n As Long
Dim box As String
Set sh2 = ThisWorkbook.Sheets(2)
Set rn2 = sh2.UsedRange
box = Sheets(1).Cells.Range("A1")
Dim k1 As Long
k1 = rn2.Rows.Count + rn2.Row - 1
n = 0
For i = 1 To k1
If Sheets(2).Cells(1, i) = box Then
If n = 0 Then
Sheets(1).Cells(3, 3).Value = Sheets(2).Cells(i, 2)
n = n + 1
End If
ElseIf n > 0 Then
For j = 3 To n + 2
If Sheets(2).Cells(2, i).Value = Sheets(1).Cells(j, 2).Value Then
If Sheets(2).Cells(2, i).Value <> Sheets(1).Cells(j, 2).Value Then
x = x
Else
x = x + 1
End If
End If
Next
If x = 0 Then
Sheets(1).Cells(3 + n, 3).Value = Sheets(2).Cells(2, i).Value
n = n + 1
End If
End If
x = 0
Next
End If
End Sub
Please let me know what you experts think!
Edit 2; the macro finds Sheet1.Range("A1").Value in Sheet2 row 1. It then loops through each cell below the found value in Sheet2. It then finds each cells value in Sheet1. It will then copy the cells value in Sheet2 from the next cell to the right, and place the value in the cell in Sheet1 to the next cell to the right. It then loops down to the next cell in sheet2, and performs the same task, etc.
Private Sub Worksheet_Change(ByVal target As Range) 'Works
Dim fndTrgt As Range, fndCel As Range
If target.Address = "$A$1" Then
Set fndTrgt = Sheets("Sheet2").Rows(1).Find(target.Value)
If Not fndTrgt Is Nothing Then
For i = 1 To 5
Set fndCel = Sheets("Sheet1").Range("A2:D12").Find(fndTrgt.Offset(i).Value)
If Not fndCel Is Nothing Then
fndCel.Offset(, 1).Value = fndTrgt.Offset(i, 1).Value
End If
Next i
End If
End If
End Sub
I am sharing my code because other code found online either does not work because it was created for excel and not access, as syntax is a little different, or is missing the key function needed, that being based off multi selection.
That said... this code does the following:
having a list box that's row source is query results the code simply puts multiple selected items from a list box in an array to be used in later code.
The difference from excel to access is .list works in excel while .Column(0, i) works in access
Dim i As Integer
Dim x As Variant
Dim MultiArr()
If Me.lbMultiEdit.ListIndex <> -1 Then
For i = 0 To Me.lbMultiEdit.ListCount - 1
If Me.lbMultiEdit.Selected(i) Then
ReDim Preserve MultiArr(x)
MultiArr(x) = Me.lbMultiEdit.Column(0, i)
x = x + 1
End If
Next i
End If
'sanity check....
For i = 0 To x - 1
MsgBox MultiArr(i)
Next i
Your code is non-optimized. It resizes the array for every item that's added. A ReDim Preserve is a very intensive operation, because it essentially creates a new array of the desired size, and then moves all items over.
A more optimized variant, that never uses ReDim Preserve:
Dim i As Integer
Dim x As Variant
Dim MultiArr()
If Me.lbMultiEdit.ItemsSelected.Count = 0 Then Exit Sub 'No items selected
ReDim MultiArr(0 To Me.lbMultiEdit.ItemsSelected.Count - 1)
If Me.lbMultiEdit.ListIndex <> -1 Then 'Why?
For i = 0 To Me.lbMultiEdit.ListCount - 1
If Me.lbMultiEdit.Selected(i) Then
MultiArr(x) = Me.lbMultiEdit.Column(0, i)
x = x + 1
End If
Next i
End If
Rather than iterating over all items and testing whether each item is selected, you could merely iterate over only the selected items, for example:
Dim i As Integer, v, MultiArr()
ReDim MultiArr(0 To Me.lbMultiEdit.ItemsSelected.Count - 1)
For Each v In Me.lbMultiEdit.ItemsSelected
MultiArr(i) = Me.lbMultiEdit.ItemData(v)
i = 1 + i
Next v
Or, using a With statement:
Dim i As Integer, v, MultiArr()
With Me.lbMultiEdit
ReDim MultiArr(0 To .ItemsSelected.Count - 1)
For Each v In .ItemsSelected
MultiArr(i) = .ItemData(v)
i = 1 + i
Next v
End With
Suppose I have a two column array in excel where the first column is text and the second column is numbers. I would like to have a command that would return an array sorted according to the values in the second column. I don't want to use the custom sort command because I would like to be able to update the numerical values in the second column and automatically have the sorted array updated.
The only other way of sorting automatically is by programming... MACROs.
You can either create a button and assign the macro to that button
OR
You put it in a selection change event which runs your macro every time a cell has changed.
up to you.
In the following code I did it for a button:
Sub btnSort()
Dim swapped As Boolean ' Boolean value to check if the values have been swapped
Dim boolEmpty As Boolean ' Boolean value to check if the cell value is empty
Dim tmp1, tmp2 As Variant ' Temporary variable,which holds temporary value
Dim numRows As Integer ' Number of NON-EMPTY rows
Dim tempArray1 As Variant ' Holds values in column 1 with certain values
Dim tempArray2 As Variant ' Holds values in column 2 with numerica values
boolEmpty = False 'Give initial value to variable; Assuming that the first checked cell is NOT EMPTY
'Count the number of cells with actual values in them
numRows = 0
ctr = 1
Do While (boolEmpty <> True)
'If the cell value contains something then increment variable numRows
If Sheet6.Cells(ctr, 1).Value > 0 Then
numRows = numRows + 1
boolEmpty = False
ctr = ctr + 1
Else
'if true then exit while loop
boolEmpty = True
End If
Loop
ReDim tempArray1(numRows) ' Re-dimensionalize the array with the appropriate size
ReDim tempArray2(numRows) ' Re-dimensionalize the array with the appropriate size
'Fill tempArray1 & 2 with values
For i = 0 To numRows - 1
tempArray1(i) = Sheet6.Cells(i + 1, 1).Value
tempArray2(i) = Sheet6.Cells(i + 1, 2).Value
Next i
'Set variables
swapped = True
ctr = 0
'If swapped remains TRUE then continue sorting the array
Do While (swapped)
swapped = False
ctr = ctr + 1
'BUBBLE SORT
'Check if next element in array is bigger than the first one.
'If TRUE then swap the elements
'If FALSE then continue until looking through teh array until done.
For i = 0 To numRows - ctr
If tempArray2(i) > tempArray2(i + 1) Then
tmp1 = tempArray1(i)
tmp2 = tempArray2(i)
tempArray1(i) = tempArray1(i + 1)
tempArray2(i) = tempArray2(i + 1)
tempArray1(i + 1) = tmp1
tempArray2(i + 1) = tmp2
swapped = True
End If
Next i
Loop
'Redisplay the sorted array in excel sheet
For i = 0 To UBound(tempArray2)
Sheet6.Cells(i + 1, 1).Value = tempArray1(i)
Sheet6.Cells(i + 1, 2).Value = tempArray2(i)
Next i
End Sub
The reason I did it for a button is because if you do it the selection change event way your excel is constantly going to refresh every time you change a cell. BUT, there is a work around for this.
In the example above I used bubble sort, you can find many examples on how to understand it online somewhere.
if you want my code to work you will have to change my sheet6.cells(....
to
your sheet number, depending where your list is found in your workbook.
In the "Count the number of cells with actual values..."
You will have to change ...Cells(ctr,1) to the row and column index where your list is found.
Hope I didn't confuse you.
Here is the other way I was talking about earlier:
'If value has changed in column 2 then run macro
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column > 1 And Target.Column < 3 Then
MsgBox Target.Column
End If
End Sub
This code needs to be in the same sheet. It checks to see if the value that you changed is in fact within column 2 ( Target.Column > 1 And Target.Column < 3 ) You can go a step further and add Target.row < 10 (which means, the cell that was modified is column 2 and less than row 10)
where you see msgbox is where you will copy and paste the code "bubble sort and etc.." in.
Hope this helps.
I've searched far and wide and I can't quite find anything to fit my needs.
The situation:
I have two lists of data with the same type data in each column (10 columns but the last 2 are useless), but the lists are of varying length (currently 55k in one, 18k in the other). The longer list is going to be a running list of items with the most up to date data in each column for the unique ID # in column A. The other list is linked to a SharePoint list that I update a couple times each day.
The need:
I need the list that updates from SharePoint to be compared to the running list. If there are matching Unique ID #'s in the lists, then the running list needs to be updated to the pulled data. If the running list doesn't contain a Unique ID that is in the pulled list, the new line needs to be added to the running list (which will be sorted later).
I first tried doing this with cell references in two for loops and for only 10 rows this worked fine. When I tried running it for every line, I had problems. So I tried using arrays instead, but this is new territory for me. The code seems to be working, but it's taking a really long time to run (I've let it go for 10 minutes before force stopping). I've tried adding some efficiency increases like turning off screen updating and calculations, but they shouldn't have any effect since I'm using arrays and not actually updating the cells until the array comparison is finished. If arrays are more efficient, great, but I don't know how to combine the data from the pulled list's array to the running list's array.
Here is the code that I have so far:
Sub Data_Compile_Cells()
Dim sdata As Worksheet, spull As Worksheet
Dim p As Long, d As Long, c As Long
Dim lrdata As Long, lrpull As Long
Dim rdata As Range, rpull As Range
Dim Newvalue As Boolean
Dim apull As Variant, adata As Variant
Dim nrows As Long, ncols As Integer
Set sdata = Sheets("Data")
Set spull = Sheets("Data Pull")
Newvalue = "FALSE"
i = 1
apull = spull.Range("A1").CurrentRegion
adata = sdata.Range("A1").CurrentRegion
'lrdata = sdata.Range("A" & Rows.Count).End(xlUp).Row
'lrpull = spull.Range("A" & Rows.Count).End(xlUp).Row
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
sdata.Activate
'*****UniqueID Check******
'Run through list of Unique ID's pulled from SharePoint
For p = 2 To UBound(apull, 1)
'I tried to add a status bar to see if the code was actually running
'Application.StatusBar = "Progress: " & p & " of " & UBound(apull, 1) & " : " & Format(p / UBound(apull, 1), "0%")
'Compare each one to the Unique ID's already listed
For d = 2 To UBound(adata, 1)
'Check for matching Unique ID's
If adata(d, 1) = apull(p, 1) Then
'Check each cell in the row with the matching Unique ID
For c = 2 To 10
'If a cell does not have the same data, replace the Data array value with the value from the Pull array
If adata(p, c) <> apull(d, c) Then
adata(d, c) = apull(p, c)
End If
Next c
'If a match is found, skip to the next p value
Exit For
Else
Newvalue = "TRUE"
'Need code to append new line to Data array
End If
Next d
Next p
'Sort the data
'Range("A2").CurrentRegion.Sort key1:=Range("A2"), order1:=xlAscending, Header:=xlYes
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Any direction would be much appreciated.
This ran in <1 sec for me, using 20k rows "data", ~3k rows "pull" (mix of updates and new).
EDIT: tidied up and added some comments...
Sub tester()
Const NUM_NEW As Long = 20000 'large enough ?
Dim arrPull, arrData, arrDataId, arrNew()
Dim ubP As Long, ubD As Long
Dim numNew As Long, r As Long
Dim v, c As Long
Dim t, tmp, coll As Collection
t = Timer
'grab the current and new data
arrPull = Sheets("Pull").Range("A1").CurrentRegion.Value
arrData = Sheets("Data").Range("A1").CurrentRegion.Value
ubP = UBound(arrPull, 1)
ubD = UBound(arrData, 1)
numNew = 0
ReDim arrNew(1 To NUM_NEW, 1 To 10) 'array for new data
'create a collection to map ID to "row number"
Set coll = New Collection
For r = 1 To ubD
coll.Add Item:=r, Key:=arrData(r, 1)
Next r
For r = 1 To ubP
tmp = arrPull(r, 1)
v = 0
'collection has no "exists" function, so trap any error
On Error Resume Next
v = coll.Item(tmp)
On Error GoTo 0
If v > 0 Then
'Id already exists: update data
For c = 2 To 10
arrData(v, c) = arrPull(r, c)
Next c
Else
'new Id: add to the "new" array
numNew = numNew + 1
If numNew > NUM_NEW Then
MsgBox "Need larger `new` array!"
'a more sophisticated approach would be to dump the full
' array to the sheet and then redimension it for more
' data...
Exit Sub
End If
For c = 1 To 10
arrNew(numNew, c) = arrPull(r, c)
Next c
End If
Next r
'drop updated and new (if any) to the worksheet
With Sheets("Data")
.Range("A1").CurrentRegion.Value = arrData
If numNew > 0 Then
.Cells(ubD + 1, 1).Resize(numNew, 10).Value = arrNew
End If
End With
Debug.Print "Done in " & Timer - t & " sec"
End Sub
You would be better off using MSAccess to do this. Link to both tables and then do an inner join on the id field or which ever field links the items in the two lists.