Matching subset of data - excel

I am populating ActiveX control labels with a subset of Excel data in VBA. My code previously worked for the entire Excel workbook, but once I changed my code to only reference a subset of the data, the incorrect data is being entered.
Here is a snapshot of example data. In my code, Column 6= CY and Column 7 = FY. The code is currently populating my labels with the headers of Column 6 and 7 rather than the values of 'active' or 'merged' projects.
As mentioned, I am not receiving any error messages, but the correct data is not being added to my ActiveX labels. FYI... In line 31 Code1 is the name of an ActiveX label.
Private Sub CommandButton1_Click()
Dim objExcel As Excel.Application
Dim exWB As Excel.Workbook
Dim rng As Excel.Range, m, rw As Excel.Range
Dim num, TableNo, seq As Integer
Dim ctl As MSForms.Label
Dim ils As Word.InlineShape
Dim rngrow As Excel.Range
Dim active As Excel.Range
Set objExcel = New Excel.Application
TableNo = ActiveDocument.Tables.Count
num = 3
seq = 1
Set exWB = objExcel.Workbooks.Open("O:\Documents\"Database.csv")
Set rng = exWB.Sheets("Sheet1").Cells
''''Select active projects as subset
For Each rngrow In rng.Range("A1:L144")
If rngrow.Columns(8).value = "Active" Or rngrow.Columns(8).value = "Merged" Then
If active Is Nothing Then
Set active = rngrow
Else
Set active = Union(active, rngrow)
End If
End If
Next rngrow
m = objExcel.Match(ActiveDocument.Code1.Caption, active.Columns(3), 0)
'' Now, create all ActiveX FY labels and populate with FY Use
Do
Set ils = ActiveDocument.Tables(num).cell(6, 2).Range.InlineShapes.AddOLEControl(ClassType:="Forms.Label.1")
Set ctl = ils.OLEFormat.Object
ctl.Name = "FY" & seq
If Not IsError(m) Then
Set rw = rng.Rows(m)
ctl.Caption = rw.Cells(7).value
Else
MsgBox "No match found"
End If
seq = seq + 1
num = num + 1
Loop Until num = TableNo + 1
'' Now, create all ActiveX CY labels and populate with CY
num = 3
seq = 1
Do
Set ils = ActiveDocument.Tables(num).cell(7, 2).Range.InlineShapes.AddOLEControl(ClassType:="Forms.Label.1")
Set ctl = ils.OLEFormat.Object
ctl.Name = "CY" & seq
If Not IsError(m) Then
Set rw = rng.Rows(m)
ctl.Caption = rw.Cells(6).value
Else
MsgBox "No match found"
End If
seq = seq + 1
num = num + 1
Loop Until num = TableNo + 1
Set exWB = Nothing
End Sub
Link to my previous question below:
Using Excel data to create Word Doc caption labels in VBA

This:
For Each rngrow In rng.Range("A1:L144")
will be interpreted as
For Each rngrow In rng.Range("A1:L144").Cells
so your loop will be A1, B1, C1, ... L1 then A2, B2 etc.
It seems like you meant it to be:
For Each rngrow In rng.Range("A1:L144").Rows
so rngRow will be A1:L1, then A2:L2, etc.
EDIT - You can't refer to active using something like MsgBox(active.Range ("A2")), since it's a multi-area range.
Try this for example -
For Each rw in active.Rows
debug.print "Row:" & rw.Row, rw.cells(8).value
Next rw
EDIT2: try this instead. Untested but I think it should work OK
Private Sub CommandButton1_Click()
Dim objExcel As Excel.Application
Dim exWB As Excel.Workbook
Dim data, r As Long, resRow As Long, seq As Long, num As Long
Dim doc As Document
'get the Excel data as a 2D array
Set objExcel = New Excel.Application
Set exWB = objExcel.Workbooks.Open("O:\Documents\Database.csv")
data = exWB.Sheets("Sheet1").Range("A1:L144").Value '>> 2D array
exWB.Close False
objExcel.Quit
resRow = 0
'find the first matching row, if any
For r = 1 To UBound(data, 1)
If (data(r, 8) = "Active" Or data(r, 8) = "Merged") And _
data(r, 3) = doc.Code1.Caption Then
resRow = r 'this is the row we want
Exit Sub 'done looking
End If
Next r
Set doc = ActiveDocument
seq = 1
For num = 3 To doc.Tables.Count
With doc.Tables(num)
AddLabel .Cell(6, 2), "FY" & seq, IIf(resRow > 0, data(resRow, 7), "Not found")
AddLabel .Cell(7, 2), "CY" & seq, IIf(resRow > 0, data(resRow, 6), "Not found")
End With
seq = seq + 1
Next num
End Sub
'add a label to a cell, set its name and caption
Sub AddLabel(theCell As Cell, theName As String, theCaption As String)
Dim ils As InlineShape, ctl As MSForms.Label
Set ils = theCell.Range.InlineShapes.AddOLEControl(ClassType:="Forms.Label.1")
Set ctl = ils.OLEFormat.Object
ctl.Name = theName
ctl.Caption = theCaption
End Sub

Related

Excel VBA save range reference

I have a range of cells which I'm scanning if the cell has a formular or not.
When it does, I want to save the column letters and row numbers i.e. E14, E18, F18, N18 (Reference) do a dictionary.
Once I've looped through my specific range, I want to select the cells saved in the dictionary to later on delete all cells with formulas in the selected cells.
I am stuck with the part to safe the cell reference to the dictionary.
The range in the example is just an example range.
Sub check_formula_empty()
Dim cell As Range
Dim i As Integer
Dim rng As Range
Set rng = Range("E13:N19")
For i = 1 To rng.Cells.Count
If rng.Cells(i).HasFormula = True And rng.Cells(i).Offset(-6, 0) = "A" Then
'save reference range to Dictionary
ElseIf rng.Cells(i).HasFormula = False And rng.Cells(i).Offset(-6, 0) = "F" Then
rng.Cells(i).Offset(-4, 0).Copy _
Destination:=rng.Cells(i)
End If
Next
'Here I want to run the "Select my saved range from the Dictionary" and run "delete formulas"
End Sub
You can us a collection for this purpose. You are mentioning a dictionary but for your purpose a key is not that important, you only need a list of items (collection supports both)
Sub check_formula_empty()
Dim cell As Range
Dim i As Integer
Dim rng As Range
Set rng = Range("E13:N19")
dim reflist as Collection
Set reflist = new Collection
For i = 1 To rng.Cells.Count
If rng.Cells(i).HasFormula = True And rng.Cells(i).Offset(-6, 0) = "A" Then
'save reference range to Dictionary
refList.Add rng.Cells(i)
ElseIf rng.Cells(i).HasFormula = False And rng.Cells(i).Offset(-6, 0) = "F" Then
rng.Cells(i).Offset(-4, 0).Copy _
Destination:=rng.Cells(i)
End If
Next
'Here I want to run the "Select my saved range from the Dictionary" and run "delete formulas"
Dim oneCell as Range
foreach oneCell in refList
oneCell.Value = vbEmpty
next
End Sub
As you can see we first add the complete cell to the collectdion (it is a referenced object) and later you can use it in the foreach loop to your liking with all its properties
So I was working on resolving the issue to run the VBA faster than looping 2-3x through each column.
My current issue, which I struggle to resolve is: that the defined range "nof" or "DBRW" keeps to increase, which when resolving my final code (delete or copy formula to the Union ranges), the whole Union ranges are selected and therefore formulars are overwritten for the full range, instead of looping from column to column and using the defined formula in that column, which is available in a fixed row (Cells(6, n)).
Option Explicit
Sub Test3()
Dim i As Integer
Dim n As Integer
Dim x As Integer
Dim DBRW As Range
Dim DBRWrange(1 To 32) As Range
Dim nof As Range
Dim nofRange(1 To 32) As Range
Dim rangef As Range
For n = 5 To 6
For i = 13 To 20
If Cells(i, n).HasFormula = True And Cells(7, n) = "A" Then
Set DBRWrange(i) = Cells(i, n)
If DBRW Is Nothing Then
Set DBRW = DBRWrange(i)
Else
Set DBRW = Union(DBRW, DBRWrange(i))
End If
ElseIf Cells(i, n).HasFormula = False And Cells(7, n) = "F" Then
Set nofRange(i) = Cells(i, n)
If nof Is Nothing Then
Set nof = nofRange(i)
Else
Set nof = Union(nof, nofRange(i))
End If
End If
Next i
Set rangef = Cells(6, n)
rangef.Copy nof
'Ranges in nof and DBRW are kept (incremented), is there a way to "refresh" the Union reference, to restart creating the range from after this step?
Next n
End Sub
ยดยดยด
so I have solved my issue and for future googlers, this might be helpful :)
Public Sub copy_paste_delete()
Dim i As Integer
Dim n As Integer
Dim DBRW As Range
Dim DBRWrange(1 To 150) As Range
Dim nof As Range
Dim nofRange(1 To 150) As Range
Dim rangef As Range
Application.ScreenUpdating = False
Worksheets("Tab1").Activate
Range("K29").Select
Set DBRW = Nothing
Set nof = Nothing
For n = 61 To 75
Set nof = Nothing
Set DBRW = Nothing
For i = 33 To 38
If Cells(i, n).HasFormula = True And Cells(6, n) = "F" Then
Set DBRWrange(i) = Cells(i, n)
If DBRW Is Nothing Then
Set DBRW = DBRWrange(i)
Else
Set DBRW = Union(DBRW, DBRWrange(i))
End If
ElseIf Cells(i, n).HasFormula = False And Cells(6, n) = "A" And Cells(7, n) = "Done" Then
Set nofRange(i) = Cells(i, n)
If nof Is Nothing Then
Set nof = nofRange(i)
Else
Set nof = Union(nof, nofRange(i))
End If
End If
Next i
Set rangef = Cells(19, n)
On Error Resume Next
rangef.Copy nof
Next n
DBRW.Select
'Do some stuff
Application.ScreenUpdating = True
End Sub

Highlight Differences across Workbook Ranges VBA

I've managed to compare 3 separate ranges on one workbook with 3 single ranges across 3 workbooks. Right now it's written to just pop up with a message box either letting me know the data is the same or the data is different. What I would like to do is for the macro to not only let me know there are differences, but to also highlight where the differences are to me. I guess this could be done by just highlighting the cells on the first workbook that are different to the other three or I guess it could also be done by pasting the different values on the sheets in question from COL N onward.
Sub Macro1()
Dim varDataMatrix() As Variant
Dim varDataMatrix2() As Variant
Dim varDataMatrix3() As Variant
Dim lngArrayCount As Long
Dim lngArrayCount2 As Long
Dim lngArrayCount3 As Long
Dim rngMyCell As Range
Dim rngMyCell2 As Range
Dim rngMyCell3 As Range
Dim wbWorkbookOne As Workbook
Dim wbWorkbookTwo As Workbook
Dim wbWorkbookThree As Workbook
Dim wbWorkbookFour As Workbook
Application.ScreenUpdating = False
Set wbWorkbookOne = Workbooks("PositionTest.xls")
Set wbWorkbookTwo = Workbooks("ATest.xlsx")
Set wbWorkbookThree = Workbooks("BTest.xlsx")
Set wbWorkbookFour = Workbooks("CTest.xlsx")
'First create an array of the values in the desired range of the first workbook.
For Each rngMyCell In wbWorkbookOne.Sheets("Positions").Range("B3:B6")
lngArrayCount = lngArrayCount + 1
ReDim Preserve varDataMatrix(1 To lngArrayCount)
varDataMatrix(lngArrayCount) = rngMyCell
Next rngMyCell
lngArrayCount = 0 'Initialise variable
'Loop through Array elements
For Each rngMyCell In wbWorkbookTwo.Sheets("A").Range("B2:B5")
lngArrayCount = lngArrayCount + 1
If rngMyCell.Value <> varDataMatrix(lngArrayCount) Then
GoTo QuitRoutinue
End If
Next rngMyCell
For Each rngMyCell2 In wbWorkbookOne.Sheets("Positions").Range("F3:F6")
lngArrayCount2 = lngArrayCount2 + 1
ReDim Preserve varDataMatrix2(1 To lngArrayCount2)
varDataMatrix2(lngArrayCount2) = rngMyCell2
Next rngMyCell2
lngArrayCount2 = 0 'Initialise variable
'Loop through Array elements
For Each rngMyCell2 In wbWorkbookThree.Sheets("B").Range("B2:B5")
lngArrayCount2 = lngArrayCount2 + 1
If rngMyCell2.Value <> varDataMatrix2(lngArrayCount2) Then
GoTo QuitRoutinue
End If
Next rngMyCell2
For Each rngMyCell3 In wbWorkbookOne.Sheets("Positions").Range("J3:J6")
lngArrayCount3 = lngArrayCount3 + 1
ReDim Preserve varDataMatrix3(1 To lngArrayCount3) 'Append the record to the existing array
varDataMatrix3(lngArrayCount3) = rngMyCell3
Next rngMyCell3
lngArrayCount3 = 0 'Initialise variable
For Each rngMyCell3 In wbWorkbookFour.Sheets("C").Range("B2:B5") 'Workbook one range is A10:A15 on 'Sheet2'.
lngArrayCount3 = lngArrayCount3 + 1
If rngMyCell3.Value <> varDataMatrix3(lngArrayCount3) Then
GoTo QuitRoutinue
End If
Next rngMyCell3
'If we get here both datasets have matched.
Set wbWorkbookOne = Nothing
Set wbWorkbookTwo = Nothing
Application.ScreenUpdating = True
Erase varDataMatrix() 'Deletes the varible contents, free some memory
MsgBox "Data is the same.", vbInformation
Exit Sub
Set wbWorkbookOne = Nothing
Set wbWorkbookTwo = Nothing
Application.ScreenUpdating = True
Erase varDataMatrix() 'Deletes the varible contents, free some memory
MsgBox "Data is different.", vbExclamation
End Sub
Highlights differences on Positions sheet and shows values in columns L to N. Uses Application.Transpose to create 1D arrays from a vertical range of cells. Note : Transpose won't work for a non-contiguous range.
Option Explicit
Sub Macro2()
Dim ws(3) As Worksheet, sht, w, n As Long
sht = Array("Positions", "A", "B", "C")
For Each w In Array("PositionTest.xls", "ATest.xlsx", "BTest.xlsx", "CTest.xlsx")
Set ws(n) = Workbooks(w).Sheets(sht(n))
n = n + 1
Next
Dim i As Long, r As Long, diff As Long
Dim rng0 As Range, rngN As Range, a As Range, b As Range
Dim ar0, arN
' compare sheets
For n = 1 To 3
Set rng0 = ws(0).Range("H5:H7,H9:H11,H13:H19,H21:H22").Offset(, (n - 1) * 4) ' H, L, P
Set rngN = ws(n).Range("E3:E18") ' sheet A, B, C
' copy to array
arN = Application.Transpose(rngN)
i = 0
For Each a In rng0
i = i + 1
r = a.Row
' cells on position sheet
Set b = ws(0).Cells(r, "R").Offset(, n) ' diff in col L,M,N
' compare arrays
If a.Value <> arN(i) Then
a.Interior.Color = RGB(255, 255, 0) ' yellow
b.Value = rngN.Cells(i, 1)
diff = diff + 1
Else
a.Interior.Pattern = False
b.Clear
End If
Next
Next
MsgBox diff & " differences", vbInformation
End Sub

Loop Through Shapes in a Workbook and rename based on Location

Long time listener, first time caller.
Anyway, I could use a bit of help. I have a macro that adds Text Boxes, and names them "Fig Num " & ActiveSheet.Shapes.count.
Once all of these text boxes are spread through out the Workbook, I would like to rename all shapes with the name "Fig Num*", or at least the text inside them, to go in order from first page to last, top to bottom, and left to right.
Currently, my code will rename the the text boxes based on seniority. In other words, if I added a text box and it was labeled "Fig Num 3", it would still be named "Fig Num 3" whether it was on the first page or last page.
enter code here
Sub Loop_Shape_Name()
Dim sht As Worksheet
Dim shp As Shape
Dim i As Integer
Dim Str As String
i = 1
For Each sht In ActiveWorkbook.Worksheets
For Each shp In sht.Shapes
If InStr(shp.Name, "Fig Num ") > 0 Then
sht.Activate
shp.Select
shp.Name = "Fig Num"
End If
Next shp
For Each shp In sht.Shapes
If InStr(shp.Name, "Fig Num") > 0 Then
sht.Activate
shp.Select
shp.Name = "Fig Num " & i
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = _
"FIG " & i
i = i + 1
End If
Next shp
Next sht
End Sub
---
I have a workbook example, but I'm not sure how to load it up, this being my first time and all.
Edit:
I have found a code that will do what I'm looking for, however it's a bit clunky. I also need a good way to find the last row on the sheet that contains a shape. Since the shape names are based on creation, if I insert a shape in row 35 and use the shape.count. featured below, it will skip all shapes after row 35 unless I add additional rows that bog down the code.
Most Recent Code (loops through grouped shapes):
Private Sub Rename_FigNum2()
'Dimension variables and data types
Dim sht As Worksheet
Dim shp As Shape
Dim subshp As Shape
Dim i As Integer
Dim str As String
Dim row As Long
Dim col As Long
Dim NextRow As Long
Dim NextRow1 As Long
Dim NextCol As Long
Dim rangex As Range
Dim LR As Long
i = 1
'Iterate through all worksheets in active workbook
For Each sht In ActiveWorkbook.Worksheets
If sht.Visible = xlSheetVisible Then
LR = Range("A1").SpecialCells(xlCellTypeLastCell).row + 200
If sht.Shapes.Count > 0 Then
With sht
NextRow1 = .Shapes(.Shapes.Count).BottomRightCell.row + 200
'NextCol = .Shapes(.Shapes.Count).BottomRightCell.Column + 10
End With
If LR > NextRow1 Then
NextRow = LR
Else
NextRow = NextRow1
End If
End If
NextCol = 15
Set rangex = sht.Range("A1", sht.Cells(NextRow, NextCol))
For row = 1 To rangex.Rows.Count
For col = 1 To rangex.Columns.Count
For Each shp In sht.Shapes
If shp.Type = msoGroup Then
For Each subshp In shp.GroupItems
If Not Intersect(sht.Cells(row, col), subshp.TopLeftCell) Is Nothing Then
If InStr(subshp.Name, "Fig Num") > 0 Then
subshp.Name = "Fig Num " & i
subshp.TextFrame2.TextRange.Characters.Text = _
"FIG " & i
i = i + 1
End If
End If
Next subshp
Else
If Not Intersect(sht.Cells(row, col), shp.TopLeftCell) Is Nothing Then
If InStr(shp.Name, "Fig Num ") > 0 Then
shp.Name = "Fig Num " & i
shp.TextFrame2.TextRange.Characters.Text = _
"FIG " & i
i = i + 1
End If
End If
End If
Next shp
Next col
Next row
End If
Next sht
End Sub
Example of Workbook:
Rename Text Boxes
To use the ArrayList, you have to have .NET Framework 3.5 SP1 installed, even if you already have a later version (e.g. 4.7) installed.
It is assumed that each text box is an ActiveX control (not a Form control) and has a (per worksheet) unique top-left cell.
Option Explicit
Sub RenameTextBoxes()
Const oTypeName As String = "TextBox" ' OLEObject Type Name
Const fPattern As String = "Fig Num " ' Find Pattern (Unsorted)
Const tPattern As String = "Dummy" ' Temporary Pattern
Const nPattern As String = "Fig Num " ' New Pattern (Sorted)
Const ByRows As Boolean = False
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim arl As Object: Set arl = CreateObject("System.Collections.ArrayList")
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim ws As Worksheet
Dim ole As OLEObject
Dim Key As Variant
Dim n As Long
Dim r As Long
Dim Coord As Double
Dim tName As String
For Each ws In wb.Worksheets
arl.Clear
dict.RemoveAll
For Each ole In ws.OLEObjects
If TypeName(ole.Object) = oTypeName Then
If InStr(1, ole.Name, fPattern, vbTextCompare) = 1 Then
n = n + 1
If ByRows Then
Coord = GetNumericByRows(ole.TopLeftCell)
Else
Coord = GetNumericByColumns(ole.TopLeftCell)
End If
arl.Add Coord
tName = tPattern & n
ole.Name = tName
dict(Coord) = tName
End If
End If
Next ole
arl.Sort
For Each Key In arl
r = r + 1
ws.OLEObjects(dict(Key)).Name = nPattern & r
'Debug.Print nPattern & r, Key, dict(Key)
Next Key
Next ws
End Sub
Function GetNumericByColumns( _
ByVal OneCellRange As Range) _
As Double
If OneCellRange Is Nothing Then Exit Function
With OneCellRange.Cells(1)
GetNumericByColumns = Val(.Column & "." & Format(.Row, "000000#"))
End With
End Function
Function GetNumericByRows( _
ByVal OneCellRange As Range) _
As Double
If OneCellRange Is Nothing Then Exit Function
With OneCellRange.Cells(1)
GetNumericByRows = Val(.Row & "." & Format(.Column, "0000#"))
End With
End Function
' Modify the range address to see what the 'GetNumeric' functions are all about.
Sub GetNumericTEST()
Dim cCell As Range: Set cCell = Sheet1.Range("XFD1048576")
Debug.Print GetNumericByColumns(cCell)
Debug.Print GetNumericByRows(cCell)
End Sub

Excel freezing when importing many rows

I created a macro to import multiple spreadsheet into on master report. I tested it with some small files without any issues. But when I am trying to import a file with more then just a couple of rows, excel keeps freezing.
Sub openFile(ByRef file As String)
Dim wbMaster As Workbook: Set wbMaster = ThisWorkbook
Dim wsMaster As Worksheet: Set wsMaster = wbMaster.Sheets("Report")
Dim tbMaster As ListObject: Set tbMaster = wsMaster.ListObjects("Report")
Dim hdrMaster As ListColumn
Dim rowMaster As ListRow
Dim wbSlave As Workbook: Set wbSlave = Workbooks.Open(Application.ActiveWorkbook.path & "\" & file)
Dim wsSlave As Worksheet
Dim rowSlave As Range
Dim cellSlave As Range
Dim hdrSlave() As Variant
For Each wsSlave In wbSlave.Worksheets
For Each rowSlave In wsSlave.Rows
If rowSlave.Row <= 1 Then
For Each cellSlave In rowSlave.Cells
If Not IsEmpty(cellSlave) Then
Set hdrMaster = Nothing
On Error Resume Next
Set hdrMaster = tbMaster.ListColumns(cellSlave.Text)
On Error GoTo 0
If hdrMaster Is Nothing Then
Set hdrMaster = tbMaster.ListColumns.Add
hdrMaster.Name = cellSlave.Text
End If
ReDim Preserve hdrSlave(cellSlave.Column)
hdrSlave(cellSlave.Column) = cellSlave.Text
Else
Exit For
End If
Next cellSlave
Else
If Not IsEmpty(rowSlave.Cells(1)) Then
Set rowMaster = tbMaster.ListRows.Add
rowMaster.Range(tbMaster.ListColumns("File").Index) = file
For Each cellSlave In rowSlave.Cells
If Not IsEmpty(cellSlave) Then
rowMaster.Range(tbMaster.ListColumns(hdrSlave(cellSlave.Column)).Index) = cellSlave.Text
Else
Exit For
End If
Next cellSlave
Else
Exit For
End If
End If
Next rowSlave
Next wsSlave
tbMaster.Range.Columns.AutoFit
wbMaster.Save
wbSlave.Close (False)
End Sub
I am also turning off ScreenUpdating before calling the sub.
Here's what I mean.
I've pulled out the process of appending a range onto a Table/Listobject into AddRangeintoTable - you would call that from your main code.
I have a stub method Tester as an example of how it would be called.
Note the comment at the bottom of the main code about whether or not you'll need to resize the table after adding the new content - there's a setting in Options to control that.
Sub Tester()
AddRangeIntoTable Range("A4").CurrentRegion, _
ActiveSheet.ListObjects("Table2"), _
True
End Sub
'append a Range onto a Table/Listobject, optionally inserting
' any columns not found in the Table
Sub AddRangeIntoTable(FromRange As Range, ToTable As ListObject, _
Optional AppendNewCols As Boolean = False)
Dim c As Range, lc As ListColumn, data, rw, col, newData(), hdr
Dim dictColPos, rngHdrs As Range, i As Long, numRows As Long, numCols As Long
data = FromRange.Value 'get all new data as array
Set dictColPos = CreateObject("scripting.dictionary") 'for mapping columns
'map headers and (optionally) add any necessary headers not already present
For col = 1 To UBound(data, 2)
hdr = data(1, col)
Set lc = Nothing
On Error Resume Next
Set lc = ToTable.ListColumns(hdr)
On Error GoTo 0
If lc Is Nothing And AppendNewCols Then 'add mising column(s)?
Set lc = ToTable.ListColumns.Add
lc.Name = hdr
End If
If Not lc Is Nothing Then
dictColPos(hdr) = lc.Index 'map header name to column index position
End If
Next col
'size array for data to append to listobject and fill it
numRows = UBound(data, 1) - 1
numCols = ToTable.ListColumns.Count
ReDim newData(1 To numRows, 1 To numCols)
For rw = 2 To UBound(data, 1)
For col = 1 To UBound(data, 2)
If dictColPos.exists(data(1, col)) Then
newData(rw - 1, dictColPos(data(1, col))) = data(rw, col)
End If
Next col
Next rw
With ToTable
With .DataBodyRange
.Rows(.Rows.Count).Cells(1).Offset(1, 0) _
.Resize(numRows, numCols).Value = newData 'add the new data
End With
' Excel options >> Proofing >> Autocorrect options >> Autoformat as you type
' >> "Include new rows and columns in table"
If Not Application.AutoCorrect.AutoExpandListRange Then
.Resize ToTable.Range.Resize(.Range.Rows.Count + numRows)
End If
.Range.Columns.AutoFit
End With
End Sub

VBA execution speed differs between Excel and Access

I have an Excel file with around 70-80 columns. I need to get the min and max values for each columns. I also need the min and max values on Access. I wrote the code both for Access and Excel and the speed of the macro is very different in both. Both are a little different but very similar.
Here is the Excel code :
Public Sub MinAndMax()
Dim i As Long, j As Long
Dim usedTime As Double
usedTime = Timer
Dim nbCol As Long, nbRow As Long
nbCol = Range("A1").End(xlToRight).Column
nbRow = Range("A1").End(xlDown).Row
Dim min As Double, max As Double
Dim temp As Variant
'First column is for the table key
'First row is for table header
For j = 2 To nbCol
min = Cells(2, j)
max = Cells(2, j)
For i = 3 To nbRow
temp = Cells(i, j)
If IsNumeric(temp) Then
If temp > max Then max = temp
If temp < max Then min = temp
End If
Next i
Next j
MsgBox "Time : " Round(Timer - duree) " seconds."
End Sub
This takes approximatively 5 seconds on Excel.
On Access, it's now a function returning an array, with an option indicating if you want the array with the max or min for each columns. So in order to get both min and max, I have to call it twice.
Private Function GetMinAndMax_Access(Optional ByVal getMin As Boolean = False) As Double()
Dim Path As String
Path = "C:\File.xlsx"
Dim appExcel As Excel.Application
Set appExcel = CreateObject("Excel.Application")
appExcel.ScreenUpdating = False
Dim wb As Workbook
Set wb = appExcel.Workbooks.Open(Path)
Dim ws As Worksheet
Set ws = wb.Worksheets(1)
Dim nbCol As Long, nbRow As Long
nbCol = ws.Range("A1").End(xlToRight).Column
nbRow = ws.Range("A1").End(xlDown).Row
ReDim extremum(2 To nbCol) As Double
Dim temp As Variant
Dim i As Long, j As Long 'Again, data start at row 2, column 2
For j = 2 To nbCol
extremum(j) = ws.Cells(2, j)
For i = 3 To nbRow
temp = ws.Cells(i, j)
If IsNumeric(temp) Then
If getMin Then
If temp < extremum(j) Then extremum(j) = temp
Else
If temp > extremum(j) Then extremum(j) = temp
End If
End If
Next i
Next j
GetMinAndMax_Access = extremum
appExcel.ScreenUpdating = True
wb.Close SaveChanges:=False
appExcel.Quit
End Function
This took precisely 29 minutes to perform on the same dataset. Note that I called the function twice, once for min values and once for max ones.
Any idea why the speeds are so different between Access and Excel, and what can be done about that ? It seems really weird to me !
Seems like a bit of a long winded way to get the minimum and maximum numeric values from the columns. The worksheet functions MIN and MAX are pretty fast at doing it so:
In Excel:
Public Sub MinAndMax()
Dim rLastCell As Range
Dim x As Long
Dim colMinMax As Collection
Set rLastCell = Cells.Find(What:="*", After:=Cells(1, 1), SearchDirection:=xlPrevious)
If Not rLastCell Is Nothing Then
Set colMinMax = New Collection
For x = 1 To rLastCell.Column
colMinMax.Add Array(Application.WorksheetFunction.min(Columns(x)), _
Application.WorksheetFunction.max(Columns(x)))
Next x
End If
End Sub
In Access (with late binding so no need to set references):
Sub ToUse()
Dim MyCol As Collection
Set MyCol = New Collection
Set MyCol = GetMinMax("C:\Documents and Settings\crladmin.ADMINNOT\My Documents\MinMax.xlsm", "Sheet1")
End Sub
Private Function GetMinMax(sPath As String, sSheet As String) As Collection
Dim oXL As Object
Dim oWB As Object
Dim oWS As Object
Dim rLastCell As Object
Dim x As Long
Dim colMinMax As Collection
Set oXL = CreateXL
Set oWB = oXL.Workbooks.Open(sPath, False)
Set oWS = oWB.Worksheets(sSheet)
Set rLastCell = oWS.Cells.Find(What:="*", After:=oWS.Cells(1, 1), SearchDirection:=2) '2 = xlPrevious
If Not rLastCell Is Nothing Then
Set colMinMax = New Collection
For x = 1 To rLastCell.Column
colMinMax.Add Array(oXL.WorksheetFunction.min(oWS.Columns(x)), _
oXL.WorksheetFunction.max(oWS.Columns(x)))
Next x
End If
End Function
Public Function CreateXL(Optional bVisible As Boolean = True) As Object
Dim oTmpXL As Object
'''''''''''''''''''''''''''''''''''''''''''''''''''''
'Defer error trapping in case Excel is not running. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''
On Error Resume Next
Set oTmpXL = GetObject(, "Excel.Application")
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
'If an error occurs then create an instance of Excel. '
'Reinstate error handling. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
If Err.Number <> 0 Then
Err.Clear
On Error GoTo ERROR_HANDLER
Set oTmpXL = CreateObject("Excel.Application")
End If
oTmpXL.Visible = bVisible
Set CreateXL = oTmpXL
On Error GoTo 0
Exit Function
ERROR_HANDLER:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & vbCr & _
" (" & Err.Description & ") in procedure CreateXL."
Err.Clear
End Select
End Function
Both procedures will return collections with 2D arrays containing MIN & MAX values for each column:
Item 1(0) - 4
Item 1(1) - 98
Item 2(0) - 3
Item 2(1) - 15

Resources