The following function returns an array to a worksheet.
I mark an area, type my function and Ctrl+Shift+Enter to get the cells filled with data from a recordset.
But if the selected area for my CSE function is larger than the returned recordset, I receive a #N/A. And if it is smaller, no warning is indicated.
Is there an easy way to replace the #N/A with "" values, and if a range of the array function smaller than the returned array - to display a warning?
Here is my current working function that returns an array from the recordset:
Function SQL(dataRange As Range, CritA As String, CritB As Double) As Variant
Application.Volatile
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim currAddress As String
Dim varHdr, varDat, varOut As Variant
Dim nc, nr, i, j As Long
SQL = Null
currAddress = ActiveSheet.Name & "$" & dataRange.Address(False, False)
strFile = ThisWorkbook.FullName
strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFile _
& ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=0"";"
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
rs.CursorLocation = adUseClient ' required to return the number of rows correctly
cn.Open strCon
strSQL = "SELECT * FROM [" & currAddress & "]" & _
"WHERE [A] = '" & CritA & "' AND [B] >= " & CritB & " " & _
"ORDER BY 10 DESC"
rs.Open strSQL, cn
' Process Column Headings
nc = rs.Fields.Count
ReDim varHdr(nc - 1, 0)
For i = 0 To rs.Fields.Count - 1
varHdr(i, 0) = rs.Fields(i).Name
Next
' Get Rows from the Recordset
nr = rs.RecordCount
varDat = rs.GetRows
' Combing Header and Data and Transpose
ReDim varOut(0 To nr, 0 To nc - 1)
For i = 0 To nc - 1
varOut(0, i) = varHdr(i, 0)
Next
For i = 1 To nr
For j = 0 To nc - 1
varOut(i, j) = varDat(j, i - 1)
Next
Next
' Optional alternative - write Output Array to Sheet2
' With Sheet2
' .Cells.Clear
' .Range("A1").Resize(nr, nc) = varOut
' End With
SQL = varOut
Erase varOut
Erase varHdr
Erase varDat
rs.Close
Set rs = Nothing
Set cn = Nothing
End Function
If your output array is smaller than the calling range, you can just fill the unused portions of the output array with "".
If the calling range is too small, you can show a message box, or return an Excel error value, or... Depends what you want.
Example of how to do these things.
Function test()
'Get interesting content
Dim contentOut As Variant
contentOut = [{1,2;3,4}] ' or a database connection, or whatever
'Figure out size of calling range which will receive the output array
Dim nRow As Long: nRow = Application.Caller.Rows.Count
Dim nCol As Long: nCol = Application.Caller.Columns.Count
'Error if calling range too small
If nRow < UBound(contentOut, 1) Or nCol < UBound(contentOut, 2) Then
'Popup message
MsgBox "your range is too small."
' or return #VALUE! error
test = CVErr(xlValue)
' or both or whatever else you want there to happen
Exit Function
End If
'Initialise output array to match size of calling range
Dim varOut As Variant
ReDim varOut(1 To nRow, 1 To nCol)
'And fill it with some background value
Dim iRow As Long
Dim iCol As Long
For iRow = 1 To nRow
For iCol = 1 To nCol
varOut(iRow, iCol) = "" ' or "funny bear", or whatever
Next
Next
'Put content in output array and return
For iRow = 1 To UBound(contentOut, 1)
For iCol = 1 To UBound(contentOut, 2)
varOut(iRow, iCol) = contentOut(iRow, iCol)
Next
Next
test = varOut
End Function
I would like to thank Jean very much for an answer and paste the complete code I owe it to those who helped me! I introduced only a small shift to the array so that the header and last column shows up.
Function SQL(dataRange As Range, CritA As String, CritB As Double) As Variant
Application.Volatile
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim currAddress As String
Dim varHdr, varDat, contentOut As Variant
Dim nc, nr, i, j As Long
SQL = Null
currAddress = ActiveSheet.Name & "$" & dataRange.Address(False, False)
strFile = ThisWorkbook.FullName
strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFile _
& ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=0"";"
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
rs.CursorLocation = adUseClient ' required to return the number of rows correctly
cn.Open strCon
strSQL = "SELECT * FROM [" & currAddress & "]" & _
"WHERE [A] = '" & CritA & "' AND [B] >= " & CritB & " " & _
"ORDER BY 10 DESC"
rs.Open strSQL, cn
' Process Column Headings
nc = rs.Fields.Count
ReDim varHdr(nc - 1, 0)
For i = 0 To rs.Fields.Count - 1
varHdr(i, 0) = rs.Fields(i).Name
Next
' Get Rows from the Recordset
nr = rs.RecordCount
varDat = rs.GetRows
' Combing Header and Data and Transpose
ReDim contentOut(0 To nr, 0 To nc - 1)
For i = 0 To nc - 1
contentOut(0, i) = varHdr(i, 0)
Next
For i = 1 To nr
For j = 0 To nc - 1
contentOut(i, j) = varDat(j, i - 1)
Next
Next
' Optional solution: Write Output Array to Sheet2
' With Sheet2
' .Cells.Clear
' .Range("A1").Resize(nr, nc) = contentOut
' End With
'Figure out size of calling range which will receive the output array
Dim nRow As Long: nRow = Application.Caller.Rows.Count
Dim nCol As Long: nCol = Application.Caller.Columns.Count
'Error if calling range too small
If nRow < UBound(contentOut, 1) Or nCol < UBound(contentOut, 2) Then
'Popup message
'MsgBox "your range is too small."
' or return #VALUE! error
SQL = "Too small range" 'CVErr(xlValue)
' or both or whatever else you want there to happen
Exit Function
End If
'Initialise output array to match size of calling range
Dim varOut As Variant
ReDim varOut(1 To nRow, 1 To nCol)
'And fill it with some background value
Dim iRow As Long
Dim iCol As Long
For iRow = 1 To nRow
For iCol = 1 To nCol
varOut(iRow, iCol) = "" ' or "funny bear", or whatever
Next
Next
'Put content in output array and return
For iRow = 0 To UBound(contentOut, 1)
For iCol = 0 To UBound(contentOut, 2)
varOut(iRow + 1, iCol + 1) = contentOut(iRow, iCol)
Next
Next
SQL = varOut
'Cleanup
Erase contentOut
Erase varHdr
Erase varDat
rs.Close
Set rs = Nothing
Set cn = Nothing
End Function
Related
I have an external workbook from which I need to get data into my main workbook.
In the past i did this using A LOT of vlookups - and as a result the calculation was extremely slow. In order to speed things up, I have tried to convert the data from the external workbook into an array(arr2), and then doing the lookups into this. The result is that it's even more slow now..
The lookup value is composed of the values from two cells. I roughly have 1000 rows which, the way i do it, needs to be looped through in 44 columns. While it is actually working on a limited amount of rows, after one hour it is still processing when listing all 1000 rows.
What can be done to speed things up?
Dim arr1() As Variant, arr2() As Variant, arr3() As Variant
Dim sup1 As Long, sup2 As Long, sup3 As Long, sup4 As Long, sup5 As Long, sup6 As Long, sup7 As Long,
sup8 As Long, sup9 As Long, sup10 As Long, sup11 As Long, sup12 As Long, sup13 As Long, sup14 As
Long, sup15 As Long
Dim i As Long, WS1 As Worksheet
Dim Book1 As Workbook, book2 As Workbook
Dim book2Name As String
book2Name = "SupportTables.xlsx"
Dim book2NamePath As String
book2NamePath = ThisWorkbook.Path & "\" & book2Name
Dim lastrow As Long
lastrow = Sheets("sheet1").Range("T" & Rows.Count).End(xlUp).Row
Set Book1 = ThisWorkbook
If IsOpen(book2Name) = False Then Workbooks.Open (book2NamePath)
Set book2 = Workbooks(book2Name)
Set WS1 = book2.Worksheets("pricediscinfo")
sup1 = Range("AN12")
sup2 = Range("AQ12")
...
sup15 = Range("CD12")
arr1 = Range("T15:T" & lastrow)
ReDim arr3(1 To UBound(arr1), 1 To 44)
arr2 = WS1.Range("a1").CurrentRegion.Value
For i = 1 To UBound(arr1)
arr3(i, 1) = Application.VLookup(arr1(i, 1) & sup1, arr2, 12, False)
arr3(i, 2) = Application.VLookup(arr1(i, 1) & sup1, arr2, 9, False)
...
arr3(i, 43) = Application.VLookup(arr1(i, 1) & sup15, arr2, 12, False)
arr3(i, 44) = Application.VLookup(arr1(i, 1) & sup15, arr2, 9, False)
Next i
Range("AN15:CE" & lastrow).Value = arr3
Any input appriciated!
Dictionaries are just a collection of key, value pairs like an 1 dimension array but with a string allowed as the key rather than just numbers. In this case because you want to look up 2 columns, the value that a key refers to I chose to be a 2 element array. For more complex cases you might just store the row number as the dictionary value and use it to get the value of any column on the lookup sheet (or array). See Dictionary Object
Update : (ws2.Cells(1, "I") corrected to (ws2.Cells(i, "I")
Option Explicit
Sub FasterLookUp()
Const WB2_NAME = "SupportTables.xlsx"
Const WS2_NAME = "pricediscinfo"
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim iLastrow As Long, i As Long
Dim arr1, arr2, arr3, sPath As String, s As String
Dim isOpen As Boolean, t0 As Single
Dim dict As Object, k
Set dict = CreateObject("Scripting.Dictionary")
Set wb1 = ThisWorkbook
Set ws1 = wb1.Sheets("Sheet1")
sPath = wb1.Path & "\"
' configuration
Dim sup(15) As String, supCol
supCol = Array("AN", "AQ", "AR", "AS", "AT", _
"AU", "AV", "AW", "AX", "AY", _
"AZ", "BA", "BB", "BC", "CD")
For i = 1 To 15
sup(i) = ws1.Cells(12, supCol(i - 1))
s = s & "sup(" & i & ") = " & sup(i) & vbCr
Next
MsgBox s ' for checking code
' open workbook if not already open
isOpen = False
For Each wb2 In Application.Workbooks
If wb2.Name = WB2_NAME Then
isOpen = True
Exit For
End If
Next
If isOpen = False Then
Set wb2 = Workbooks.Open(sPath & "\" & WB2_NAME, True, True) ' update links, read only
End If
Set ws2 = wb2.Sheets(WS2_NAME)
iLastrow = ws2.Cells(Rows.Count, "A").End(xlUp).Row
' build dictionary as lookup table
t0 = Timer
For i = 1 To iLastrow
k = Trim(ws2.Cells(i, "A")) ' key
If Len(k) > 0 Then
If dict.exists(k) Then
MsgBox "Duplicate key " & k, vbCritical, "Row " & i
Exit Sub
Else
' col I and col L
dict.Add k, Array(ws2.Cells(i, "I"), ws2.Cells(i, "L")) ' lookups
End If
End If
Next
MsgBox dict.Count & " Items scanned into dictionary from " & ws2.Name, _
vbInformation, "Took " & Int(Timer - t0) & " seconds"
' update this workbook
t0 = Timer
iLastrow = ws1.Cells(Rows.Count, "T").End(xlUp).Row
arr1 = ws1.Range("T15:T" & iLastrow)
ReDim arr3(UBound(arr1), 1 To 44)
For i = 1 To UBound(arr1)
s = arr1(i, 1)
k = s & sup(1)
If dict.exists(k) Then
arr3(i, 1) = dict(k)(1) ' col L
arr3(i, 2) = dict(k)(0) ' col I
Else
'Debug.Print "No match '" & k & "'"
End If
''
k = s & sup(15)
If dict.exists(k) Then
arr3(i, 1) = dict(k)(1) ' col L
arr3(i, 2) = dict(k)(0) ' col I
Else
'Debug.Print "No match '" & k & "'"
End If
Next i
If isOpen = False Then wb2.Close False ' close if opened
ws1.Range("AN15:CE" & iLastrow).Value = arr3
MsgBox "Udate done", vbInformation, "Took " & Int(Timer - t0) & " seconds"
End Sub
i tried using dictionary but it only counts the repetition but i want to know the exact frequency of all datas in a column
what ive used is
Sub countThings()
Dim ws As Worksheet
Dim lastrow As Long, x As Long
Dim items As Object
Application.ScreenUpdating = False
Set ws = ActiveSheet
lastrow = ws.Range("B" & Rows.count).End(xlUp).Row
Set items = CreateObject("Scripting.Dictionary")
For x = 2 To lastrow
If Not items.exists(ws.Range("B" & x).Value) Then
items.Add ws.Range("B" & x).Value, 1
ws.Range("C" & x).Value = items(ws.Range("B" & x).Value)
Else
items(ws.Range("B" & x).Value) = items(ws.Range("B" & x).Value) + 1
ws.Range("C" & x).Value = items(ws.Range("B" & x).Value)
End If
Next x
items.RemoveAll
End Sub
and this gives me
[1: https://i.stack.imgur.com/Mhp5g.png][1]
but what i need is
[4: https://i.stack.imgur.com/UYOFu.png][4]
I think this is what you were after. Please try it.
Sub CountThings()
Dim Ws As Worksheet
Dim Items As Object ' Scripting.Dictionary
Dim Arr As Variant ' values in column B
Dim R As Long ' loop couner: Rows
Dim Key As Variant ' loop counter: dictionary keys
Set Items = CreateObject("Scripting.Dictionary")
Set Ws = ActiveSheet ' better: define tab by name
With Ws
' reading from the sheet is slow
' therefore read all items at once
Arr = .Range(.Cells(2, "B"), .Cells(.Rows.Count, "B").End(xlUp)).Value
' this is a 1-based 2-D array, like Arr([Rows], [Column])
' where column is always 1 because there's only 1 column
End With
For R = 1 To UBound(Arr)
If Items.Exists(Trim(Arr(R, 1))) Then
Items(Trim(Arr(R, 1))) = Items(Trim(Arr(R, 1))) + 1
Else
Items.Add Trim(Arr(R, 1)), 1
End If
Next R
ReDim Arr(1 To Items.Count, 1 To 2)
R = 0
For Each Key In Items.keys
R = R + 1
Arr(R, 1) = Key
Arr(R, 2) = Items(Key)
Next Key
' specify the top left cell of the target range
Ws.Cells(2, "C").Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr
Set Items = Nothing
End Sub
You need not Trim the Keys if you are sure that there can't be any stray leading or trailing blanks.
Your second picture doesn't need VBA. It can be produce by this formula, entered in C2 and copied down.
=COUNTIF($B$2:$B$13,$B2)
In fact, you can even do the job of my above code without VBA. Enter this formula in G2 of your sheet as an array formula (confirmed with CTL + SHIFT + ENTER if you don't have Excel 365), and the other one in H. Then copy both formulas down.
[G2] =IFERROR(INDEX($B$2:$B$13, MATCH(0, COUNTIF($G$1:G1, $B$2:$B$13), 0)), "")
[H2] =IF($G2<>"",COUNTIF($B$2:$B$13,$G2),"")
You need to assign values to column C after you have finished counting and therefore, need another loop:
Sub countThings()
Dim ws As Worksheet
Dim lastrow As Long, x As Long
Dim items As Object
Application.ScreenUpdating = False
Set ws = ActiveSheet
lastrow = ws.Range("B" & Rows.Count).End(xlUp).Row
Set items = CreateObject("Scripting.Dictionary")
For x = 2 To lastrow
If Not items.exists(ws.Range("B" & x).Value) Then
items.Add ws.Range("B" & x).Value, 1
Else
items(ws.Range("B" & x).Value) = items(ws.Range("B" & x).Value) + 1
End If
Next x
For x = 2 To lastrow
ws.Range("C" & x).Value = items(ws.Range("B" & x).Value)
Next x
items.RemoveAll
Set items = Nothing
End Sub
A simpler way to achieve what you want is to let excel do the counting for you like this:
Sub countThings2()
Dim sDataAddress As String
With ActiveSheet
sDataAddress = "$B$2:$B$" & .Cells(Rows.Count, "B").End(xlUp).Row
With .Range(sDataAddress).Offset(0, 1)
.Formula2 = "=COUNTIF(" & sDataAddress & ",B2)"
.Value = .Value
End With
End With
End Sub
i use table and 2 functions. not simple way but works :)
Sub Fx()
Dim str_Tab() As String, str_Text As String, str_Result As String
Dim int_Counter As Integer, int_TabItemCounter As Integer, int_LastRow As Integer
Dim rng_WorkRange As Range
int_LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Set rng_WorkRange = ActiveSheet.Range("A1:A" & int_LastRow)
For i = 1 To int_LastRow
str_Text = ActiveSheet.Range("A" & i)
If i > 1 Then
str_Result = IsInArray(str_Text, str_Tab)
If str_Result = -1 Then
int_TabItemCounter = UBound(str_Tab) - LBound(str_Tab)
ReDim str_Tab(int_TabItemCounter)
str_Tab(int_TabItemCounter) = str_Text
ActiveSheet.Range("B" & i) = CountThisItem(rng_WorkRange, str_Text)
Else
ActiveSheet.Range("B" & i) = CountThisItem(rng_WorkRange, str_Text)
End If ' If str_Result = -1
Else ' If i > 1
ReDim str_Tab(i)
str_Tab(i) = str_Text
ActiveSheet.Range("B" & i) = CountThisItem(rng_WorkRange, str_Text)
End If ' If i > 1
Next i
End Sub
function to check is text in table
Function IsInArray(stringToBeFound As String, arr As Variant) As Long
Dim i As Long
' default return value if value not found in array
IsInArray = -1
For i = LBound(arr) To UBound(arr)
If StrComp(stringToBeFound, arr(i), vbTextCompare) = 0 Then
IsInArray = i
Exit For
End If
Next i
End Function
function to count item in range
Function CountThisItem(CountingRange As Range, a As String) As Integer
Dim rng_FindRange As Range
Dim LA As String
Set rng_FindRange = CountingRange.Find(a, lookat:=xlWhole)
If Not rng_FindRange Is Nothing Then
LA = rng_FindRange.Address
CountThisItem = 1
Do
Set rng_FindRange = CountingRange.Find(a, lookat:=xlWhole, after:=rng_FindRange)
If Not rng_FindRange Is Nothing And rng_FindRange.Address <> LA Then CountThisItem = CountThisItem + 1
Loop While rng_FindRange.Address <> LA
Else
CountThisItem = 0
End If
End Function
Currently I am trying to improve the performance of my VBA program, because it takes forever to perform some table operations.
During the programs runtime I am trying to store data in worksheets, but the write-operations take for ever and I would like to store this data dynamically instead of writing it into a worksheet to reduce the time it needs to run.
I was thinking about using arrays instead of the worksheets to store the data but I am not quite sure whether this will work because I do not know how many rows/columns my table exactly has.
Here my code, any help is appreciated!
Public row As Long
Public rowMax As Long
Public startRow As Integer
Public materialType As String
Public filter As String
Public col As Integer
Public colMax As Integer
Public isUsed As Boolean
Public a As Integer
Sub bestimmeObFelderGenutzt()
Debug.Print ("bestimmeObFelderGenutzt:begin" & " " & Now())
With Sheets("Sheet1")
filter = "I"
startRow = 2
rowMax = Sheets("Sheet1").Cells(.Rows.Count, "F").End(xlUp).row
colMax = Sheets("Sheet1").Cells(1, .Columns.Count).End(xlToLeft).Column
materialType = Sheets("Sheet1").Range(filter & startRow).Value
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = "Nutzung"
For col = 1 To colMax
Sheets("Nutzung").Cells(1, col + 2).Value = Sheets("Sheet1").Cells(1, col).Value
Next col
For row = 2 To rowMax
Sheets("Nutzung").Range("A" & row).Value = Sheets("Sheet1").Range("A" & row).Value
Sheets("Nutzung").Range("B" & row).Value = Sheets("Sheet1").Range("I" & row).Value
For col = 1 To colMax
If IsEmpty(Sheets("Sheet1").Cells(row, col)) = False Then
isUsed = True
Sheets("Nutzung").Cells(row, col + 2).Value = 1
Else:
Sheets("Nutzung").Cells(row, col + 2).Value = 0
End If
Next col
Next row
End With
Debug.Print ("bestimmeObFelderGenutzt:end" & " " & Now())
End Sub
Sub findeUngenutzteSpalten(ByVal materialType As String, pos As Integer)
Debug.Print ("findeUngenutzteSpalten:begin" & " " & materialType & " " & Now())
With Sheets(materialType)
rowMax = Sheets(materialType).Cells(.Rows.Count, "F").End(xlUp).row
colMax = Sheets(materialType).Cells(1, .Columns.Count).End(xlToLeft).Column
Sheets("Auswertung").Cells(1, 1).Value = "Spaltenüberschrift:"
Dim a As Integer
For a = 1 To colMax
Sheets("Auswertung").Cells(a + 1, 1).Value = Sheets("Sheet1").Cells(1, a).Value
Next a
Sheets("Auswertung").Cells(1, pos + 1).Value = materialType
For col = 3 To colMax
For row = 2 To rowMax
If Sheets(materialType).Cells(row, col).Value = 1 Then
Sheets("Auswertung").Cells(col - 1, pos + 1).Value = "Ja"
GoTo WeiterCol
Else:
If row = rowMax Then
Sheets("Auswertung").Cells(col - 1, pos + 1).Value = "Nein"
Else:
GoTo WeiterRow
End If
End If
WeiterRow:
Next row
WeiterCol:
Next col
End With
Debug.Print ("findeUngenutzteSpalten:end" & " " & materialType & " " & Now())
End Sub
Sub kopiereZeilen(ByVal materialType As String)
Debug.Print ("kopiereZeilen:begin" & " " & materialType & " " & Now())
With Sheets("Nutzung")
rowMax = Sheets("Nutzung").Cells(.Rows.Count, "F").End(xlUp).row
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = materialType
Sheets("Nutzung").Cells(1, 1).EntireRow.Copy Sheets(materialType).Cells(1, 1)
Dim unusedRow As Long
For row = 2 To rowMax
unusedRow = Sheets(materialType).Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).row
If Sheets("Nutzung").Cells(row, 2).Value = materialType Then
Sheets("Nutzung").Cells(row, 2).EntireRow.Copy Sheets(materialType).Cells(unusedRow, 1)
End If
Next row
End With
Debug.Print ("kopiereZeilen:end" & " " & materialType & " " & Now())
End Sub
Sub allesZusammen()
Debug.Print ("Hauptaufruf:begin" & " " & Now())
Dim types(10) As String
Dim element As Variant
Dim pos As Integer
bestimmeObFelderGenutzt
types(0) = "A"
types(1) = "B"
types(2) = "C"
types(3) = "D"
types(4) = "E"
types(5) = "F"
types(6) = "G"
types(7) = "H"
types(8) = "I"
types(9) = "J"
types(10) = "K"
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = "Auswertung"
For Each element In types
kopiereZeilen (element)
pos = Application.Match(element, types, False)
findeUngenutzteSpalten element, pos
Next element
Debug.Print ("Hauptaufruf:end" & " " & Now())
End Sub
You can declare dynamic arrays. The general syntax is:
Dim Values() As Long
To use the array, you must first re-dimension it to the size you want. For example this declares a two-dimensional array of 3 x 5 values (zero based):
ReDim Values(2, 4)
If you want to size based on variables then use something like:
ReDim Values(myrowsize, mycolumnsize)
You can grow (or shrink) the array dynamically by using this syntax:
ReDim Preserve Values(2, mynewsize)
Note, that you can only re-dimension the last index of the array. So this is not allowed:
ReDim Preserve Values(mynewsize, 4)
But this is probably ok in your case, as you have a fixed number of columns.
It is perfectly ok to declare the dynamic array as a UDT. For example:
Type UDTInfo
valueA As Long
valueB As Long
End Type
Sub test()
Dim Values() As UDTInfo
ReDim Values(2, 4)
ReDim Preserve Values(2, 5)
End Sub
You can access the array in the normal way:
x = Values(1, 2)
You can copy one dynamic array to another directly, as long as the types and number of dimensions match (size doesn't matter):
Dim Values() As Integer
Dim Results() As Integer
Results = Values
And lastly, you can pass dynamic arrays to and from functions in the following way:
Function SomeFunc(ByRef Values() As Long) As Long()
Dim ReturnValues() As Long
ReturnValues = Values
SomeFunc = ReturnValues
End Function
Note, you only pass dynamic arrays ByRef but not ByVal.
Following is the VBA code to fetch data from oracle database to excel.
Instead of the data going to some random sheet I want the data related to collabname 301_CBCompanySync_SAP_to_HHT to be gone into a sheet named 301_CBCompanySync_SAP_to_HHT and the
data related to the collabname 302_CBCustomer_SAP_to_HHT to be gone into sheet named "302_CBCustomer_SAP_to_HHT" ..so on
How shall I modify the below code
Sub Load_data()
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim col As Integer
Dim row As Integer
Dim Query As String
Dim mtxData As Variant
Set cn = New ADODB.Connection
Set rs = New ADODB.Recordset
cn.Open ( _
"User ID=xxxx" & _
";Password=xxxxx" & _
";Data Source=xx.xx.xx.xxx:xxxx/xxxxxx" & _
";Provider=OraOLEDB.Oracle")
Dim arrayCollabName As Variant
Dim idx As Integer
idx = 0
arrayCollabName = Array("301_CBCompanySync_SAP_to_HHT", "302_CBCustomer_SAP_to_HHT", "303_CustomerExclusionList_SAP_to_HHT")
For idx = 0 To 2
Sheets("Sheet1").Select
Sheets.Add
rs.Open "select COLLABNAME,DATETIME,TOTALFLOWS,SUCCFLOWS,FAILEDFLOWS from EWS_COLLAB WHERE COLLABNAME like '" & arrayCollabName(idx) & "'", cn
col = 0
Do While col < rs.Fields.Count
.Cells(1, col + 1) = rs.Fields(col).Name
col = col + 1
Loop
mtxData = Application.Transpose(rs.GetRows)
.Range("A2").Resize(UBound(mtxData, 1) - LBound(mtxData, 1) + 1, UBound(mtxData, 2) - LBound(mtxData, 2) + 1) = mtxData
End With
rs.Close
Next
cn.Close
End Sub
so, hope its ok.
Sub Load_data()
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim col As Integer
Dim row As Integer
Dim Query As String
Dim mtxData As Variant
Dim arrayCollabName As Variant
Dim idx As Integer
Set cn = New ADODB.Connection
Set rs = New ADODB.Recordset
idx = 0
'array with all collab names
arrayCollabName = Array("301_CBCompanySync_SAP_to_HHT", "302_CBCustomer_SAP_to_HHT", "303_CustomerExclusionList_SAP_to_HHT")
'connect to Database
cn.Open ( _
"User ID=xxxx" & _
";Password=xxxxx" & _
";Data Source=xx.xx.xx.xxx:xxxx/xxxxxx" & _
";Provider=OraOLEDB.Oracle")
'loop for inserting the Data from the SQL
For idx = 0 To 2
Sheets("Sheet1").Select
Sheets.Add
'Rename the new added sheet
If Len(arrayCollabName(idx)) > 31 Then
ActiveSheet.Name = Left(arrayCollabName(idx), 31)
Else
ActiveSheet.Name = arrayCollabName(idx)
End If
'database query
rs.Open "select COLLABNAME,DATETIME,TOTALFLOWS,SUCCFLOWS,FAILEDFLOWS from EWS_COLLAB WHERE COLLABNAME like '" & arrayCollabName(idx) & "'", cn
col = 0
Do While col < rs.Fields.Count
.Cells(1, col + 1) = rs.Fields(col).Name
col = col + 1
Loop
mtxData = Application.Transpose(rs.GetRows)
.Range("A2").Resize(UBound(mtxData, 1) - LBound(mtxData, 1) + 1, UBound(mtxData, 2) - LBound(mtxData, 2) + 1) = mtxData
End With
'database query with the search results closing
rs.Close
Next
'database connection closed
cn.Close
End Sub
Sub deletSheets()
Dim idx As Integer
Application.DisplayAlerts = False
For idx = 0 To ActiveWorkbook.Sheets.Count
If Not ActiveSheet.Name = "Sheet1" Then
ActiveWindow.SelectedSheets.Delete
End If
Next idx
Application.DisplayAlerts = True
End Sub
I have a string which is in A1 of Sheet1 and it refreshes regularly.
it looks like this -
{"rows":[{"advances":637,"declines":836,"unchanged":76,"total":1549}],"success":"true","results":1}
I want to extract numeric values 637 and 836 and 76 and store it in separate columns. The values keeps on changing, like 637 can be sometimes 1200.
I want a VBA code, not an user defined function to automatically extract the numeric data and store it.
I am using this code, but I am not getting anything. What is wrong?
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
Dim s As String
Dim fieldNames As Variant
Dim iField As Long
Dim nFields As Long
Dim v As Variant
' specify what you want
fieldNames = Array("advances", "declines", "unchanged")
nFields = UBound(fieldNames) - LBound(fieldNames) + 1
s = [a1].Value ' read in the string
' parse it, put values in a Variant array
ReDim v(1 To 1, 1 To nFields)
For iField = 1 To nFields
s = Mid(s, InStr(s, """" & fieldNames(iField - 1) & """:") _
+ Len(fieldNames(iField - 1)) + 3)
v(1, iField) = Left(s, InStr(s, ",") - 1)
Next iField
' write array to sheet
[b1].Resize(1, nFields).Value = v
End If
Range("=Sheet1!$E$1:$G$1").Copy Destination:=Sheets("Updated").Range("B" & Rows.Count).End(xlUp).Offset(1)
Sheets("Updated").Range("A" & Rows.Count).End(xlUp).Offset(1).Value = Now
End Sub
While I would be tempted to use standard functions for this you could run a VBA UDF like so
to get the first match from A1 (as a number)
=RegexMatches(A1,1)
the second match
=RegexMatches(A1,2)
and so on
The UDF returns "No Match" where no matches are found, or a message "Less than X matches" if you try to extract a match from a position that doesb't exist
Function RegexMatches(strIn As String, LngPos As Long)
Dim objRegex
Dim objRegexMC
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Global = True
.Pattern = ":(\d+),"
If .test(strIn) Then
Set objRegexMC = .Execute(strIn)
If objRegexMC.Count >= LngPos Then
RegexMatches = CLng(objRegexMC(LngPos - 1).submatches(0))
Else
RegexMatches = "Less than " & LngPos & " matches"
End If
Else
RegexMatches = "No Match"
End If
End With
End Function
[Update: added sheet event code]
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng1 As Range
Set rng1 = Sheets("Updated").Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
'set row1 as first row if it is blank
If rng1.Row = 2 And rng1.Offset(-1, 0) = vbNullString Then Set rng1 = rng1.Offset(-1, 0)
rng1.Resize(1, 3).Value = Range("B1:D1").Value
rng1.Offset(0, -1).Value = Now
End Sub
You can use an instance of the windows script control to parse the text for you:
Sub Tester()
Dim JSON As String
Dim sc As Object
JSON = "{""rows"":[{""advances"":637,""declines"":836," & _
"""unchanged"":76,""total"":1549}]" & _
",""success"":""true"",""results"":1}"
'JSON = ActiveSheet.Range("A1").Value
Set sc = CreateObject("ScriptControl")
sc.Language = "JScript"
sc.Eval "var o = eval(" & JSON & ")" 'evaluate to an object
Debug.Print "success", sc.Eval("o.success")
Debug.Print "#results", sc.Eval("o.results")
Debug.Print " advances", sc.Eval("o.rows[0].advances")
Debug.Print " declines", sc.Eval("o.rows[0].declines")
Debug.Print " unchanged", sc.Eval("o.rows[0].unchanged")
End Sub
I needed something similar and developed the following code. I have no doubts that it could be made more sophisticated but it provided me with the required result.
Dim cr_ref As String ' Original reference - alpha and numer
Dim new_ref As String ' Resultant numeirc only reference
Dim iAsciiCode As Integer
Dim sCount As Integer ' Length of reference
cr_ref = Trim(Cells(4, 19).Value) ' Get reference from source
sCount = Len(cr_ref)
new_ref = "" ' Start with empty result
For i = 0 To sCount - 1 ' Strip out all except digits
iAsciiCode = Asc(Mid(cr_ref, i + 1, 1)) ' Give me Ascii code
If iAsciiCode >= 48 And iAsciiCode <= 57 Then ' I only want 0-9
new_ref = new_ref & Mid(cr_ref, i + 1, 1) ' Append numeric digit
End If
Next i
' Result is in new_ref
This works:
Dim s As String
Dim fieldNames As Variant
Dim iField As Long
Dim nFields As Long
Dim v As Variant
' specify what you want
fieldNames = Array("advances", "declines", "unchanged")
nFields = UBound(fieldNames) - LBound(fieldNames) + 1
s = [a1].Value ' read in the string
' parse it, put values in a Variant array
ReDim v(1 To 1, 1 To nFields)
For iField = 1 To nFields
s = Mid(s, InStr(s, """" & fieldNames(iField - 1) & """:") _
+ Len(fieldNames(iField - 1)) + 3)
v(1, iField) = Left(s, InStr(s, ",") - 1)
Next iField
' write array to sheet
[b1].Resize(1, nFields).Value = v