I am trying to replicate what a Data Table does in excel in VBA. I have got the code working as I want thus far however when I copy data out of the temporary storage array it is offset by 1 Column and 1 Row.
I cannot figure out what the issue is? Thanks in advance.
Sub DataTableLoop()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim CodeRng As Range
Dim PasteRng As Range
Dim WatchRng As Range
Dim ResultRng As Range
Dim ResultRes As Range
Dim x As Integer
Dim y As Integer
Dim i As Integer
Dim Count As Integer
Dim col As Integer
Dim MyArray As Variant
Dim TempArr As Variant
Dim CodeVar As Range
Set CodeRng = Worksheets("OptionCodes").[CodeTop]
Set PasteRng = Worksheets("OptionCodes").[OptionsCode]
Set WatchRng = Worksheets("OptionCodes").[WatchRange]
Set ResultRng = Worksheets("OptionCodes").[ResultsRange]
col = WatchRng.Columns.Count
x = Worksheets("OptionCodes").[Iterations].Value
y = x - 1
i = 0
Set ResultRes = ResultRng.Resize(x)
ReDim MyArray(x, col)
Do While i <= y
Set CodeVar = CodeRng.Offset(i, 0)
Count = i + 1
Application.StatusBar = "Iteration: " & Count & " of " & x
CodeVar.Copy
PasteRng.PasteSpecial Paste:=xlPasteValues
Application.Calculate
TempArr = WatchRng
For j = 1 To col
MyArray(Count, j) = TempArr(1, j)
Next j
i = i + 1
Loop
ResultRes = MyArray
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Redim is by default 0 based, so your array is actually 1 row and column larger than you expect. To get 1 based you need to specify the lower bounds
ReDim MyArray(1 To x, 1 To col)
Related
I am looking for if it is possible to get the data and headers from a table as in the example image and have the output go to two columns with the first column being a repeating header? I did try the transpose however the email row kept populating up to column E.
Please, try the next way. It uses arrays being fast even for large ranges, mostly working in memory. It returns starting from "F2". It is able to process any other columns you (may) need, after "Status":
Sub TransposeMails()
Dim sh As Worksheet, lastR As Long, lastCol As Long
Dim arrH, arr, arrFin, i As Long, j As Long, k As Long
Set sh = ActiveSheet 'use here the necessary sheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row 'last row
lastCol = sh.cells(1, sh.Columns.count).End(xlToLeft).column 'last column
arrH = Application.Transpose(sh.Range(sh.cells(1, 1), sh.cells(1, lastCol)).Value2) 'place headers in an array
arr = sh.Range("A2", sh.cells(lastR, lastCol)).Value2 'place the range to be processed (except headers) in an array for faster iteration/processing
ReDim arrFin(1 To (UBound(arrH) + 1) * UBound(arr), 1 To 2) 'Redim the final array (keeping the processed result)
'+ 1 for the empty rows in between...
For i = 1 To UBound(arr)
For j = 1 To UBound(arrH)
k = k + 1
arrFin(k, 1) = arrH(j, 1): arrFin(k, 2) = arr(i, j)
Next j
k = k + 1 'for the empty row between groups...
Next i
'drop the processed array content:
sh.Range("G2").Resize(UBound(arrFin), 2).Value2 = arrFin
End Sub
The code can be easily adapted to return anywhere (another sheet, workbook, range etc).
The range to be processed must start from "A1" ("Email" header) and not having any other record after the last header (on the first row)...
Transpose Data
Sub TransposeData()
Const SRC_NAME As String = "Sheet1"
Const DST_NAME As String = "Sheet1"
Const DST_FIRST_CELL As String = "A8"
Const EMPTY_COLS As Long = 0
Const EMPTY_ROWS As Long = 1
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Sheets(SRC_NAME)
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
Dim drOffset As Long: drOffset = srg.Columns.Count + EMPTY_ROWS
Dim dcOffset As Long: dcOffset = 1 + EMPTY_COLS
Dim dws As Worksheet: Set dws = wb.Sheets(DST_NAME)
Dim dfCell As Range: Set dfCell = dws.Range(DST_FIRST_CELL)
Application.ScreenUpdating = False
Dim srrg As Range, shrg As Range
Dim IsHeaderReady As Boolean, IsFirstRowDone As Boolean
For Each srrg In srg.Rows
If Not IsHeaderReady Then
srrg.Copy
dfCell.PasteSpecial Transpose:=True
Set shrg = dfCell.Resize(srg.Columns.Count) ' transpose no more
IsHeaderReady = True
Else ' header is ready; it's already copied for the first data row
If IsFirstRowDone Then shrg.Copy dfCell Else IsFirstRowDone = True
srrg.Copy
dfCell.Offset(, dcOffset).PasteSpecial Transpose:=True
Set dfCell = dfCell.Offset(drOffset)
End If
Next srrg
Application.ScreenUpdating = True
MsgBox "Data transposed.", vbInformation
End Sub
If I understand you correctly
Sub test()
'set the range of the header as rg variable
'count how many data under EMAIL header as cnt variable
Dim rg As Range: Set rg = Range("A1", Range("A1").End(xlToRight))
Dim cnt As Integer: cnt = Range(rg, rg.End(xlDown)).Rows.Count - 1
Dim i As Integer: Dim rslt As Range
'loop to each range with data as many as the cnt value
'prepare the result range as rslt variable
'put the value of header name to rslt range
'put the looped range value to rslt.offset(0,1)
For i = 1 To cnt
Set rslt = Range("A" & Rows.Count).End(xlUp).Offset(3, 0) _
.Resize(rg.Columns.Count, 1)
rslt.Value = Application.Transpose(rg)
rslt.Offset(0, 1).Value = Application.Transpose(rg.Offset(i, 0))
Next
End Sub
Please note, the code must be run where the sheet contains the data is active.
This is a follow up question to my previous VBA question. Someone provided me with a potential solution for a lag in performance, and mentioned instead of looping through the actual cells in each column, transform the columns into Arrays and then load the results into a new Array.
I keep getting "subscript out of range" issues, among other various errors. I've manipulated these Arrays so many times with ReDim and others to try to load the results, but I keep hitting the same issue. You will see some of the code I tried where things are commented out.
How can I properly load these results based on the information I have? I thought at first it was because I was declaring a dynamic, empty Array, so that's why I used the UBound of an array of the same size in a ReDim.
Sub Missing_CAT():
Dim i As Variant
Dim j As Variant
'Dim j As Long
'Dim h As Long
'Dim h As Variant
Dim d As Date
Dim e As Date
Dim f As Date
Dim a As String
Dim ws As Worksheet
Dim rowCount As Long
Dim secondRowCount As Long
Dim oDateArr() As Variant
Dim fromDateArr() As Variant
Dim toDateArr() As Variant
Dim perilArr() As Variant
Dim resultArr() As Variant
Dim cell As Variant
Dim counter As Variant
Dim count As Long
Dim boundary As Long
Dim ub As Integer
rowCount = Worksheets("raw_data_YOA").Cells(Rows.count, "A").End(xlUp).row
oDateArr = Sheets("raw_data_YOA").Range("Q2:Q" & rowCount).Value
ub = UBound(oDateArr)
ReDim resultArr(ub)
count = 0
'For i = 2 To rowCount
For Each i In oDateArr
'd = Worksheets("raw_data_YOA").Cells(i, 17).Value
d = i
For Each ws In Sheets
If ws.Name = "2020" Or ws.Name = "2019" Then
secondRowCount = ws.Cells(Rows.count, "D").End(xlUp).row
fromDateArr = ws.Range("D5:D" & secondRowCount).Value
toDateArr = ws.Range("E5:E" & secondRowCount).Value
perilArr = ws.Range("F5:F" & secondRowCount).Value
' For j = 5 to secondRowCount
'For Each j In fromDateArr
'boundary = UBound(fromDateArr)
For j = 1 To UBound(fromDateArr)
' MsgBox (fromDateArr(j))
e = fromDateArr(j, 1)
f = toDateArr(j, 1)
p = perilArr(j, 1)
'e = ws.Cells(j, 4).Value
' f = ws.Cells(j, 5).Value
If d >= e And d <= f Then
' ReDim Preserve resultArr(1 To UBound(resultArr) + 1)
' resultArr(UBound(resultArr), 1) = p
resultArr(count) = p
Exit For
ElseIf j = UBound(fromDateArr) Then
' Worksheets("raw_data_YOA").Cells(i, 63).Value = "FALSE"
' ReDim Preserve resultArr(1 To UBound(resultArr) + 1)
' MsgBox (UBound(resultArr))
resultArr(count) = "FALSE"
End If
Next j
Else
GoTo NextIteration
End If
count = count + 1
NextIteration:
Next
Next i
counter = 0
For Each cell In Sheets("raw_data_YOA").Range("Q2:Q" & rowCount)
cell.Value = resultArr(counter)
counter = counter + 1
Next
MsgBox ("Done")
End Sub
EDIT:
Specifically, the lines throwing the errors are resultArr(count) = ...
I cannot get to work condition for matching 2D arrays. I have tried another approach and this one is closer to the solution, but still does not produce the outcome.
This is what I want to do:
In sheet1 I have different dates that go through columns and size is uncertain. Below these dates are the values:
In sheet 2, I have a smaller subset of dates (that should exist in sheet1):
Through the code, I want to match the dates in sheet1 and sheet2, and only if match is true, I want to write the corresponding values from sheet1 to sheet2.
This is the outcome:
I want to use Arrays for dates in sheet1 and sheet2 and if they match, write the array of values. But the arrays of dates turn to be empty and so condtion for match does not work. I am not getting any error message as well:
Sub test()
Dim arrAmounts() As Variant
Dim arrDates_w2() As Variant
Dim arrDates_w1() As Variant
Dim Lastcol_w2 As Integer
Dim Lastcol_w1 As Integer
Dim LastRow As Integer
Dim i As Integer
Dim w As Integer
Dim d As Integer
Dim f As Integer
Dim g As Integer
Dim w1 As Worksheet
Dim w2 As Worksheet
Set w1 = Sheets("Sheet1")
Set w2 = Sheets("Sheet2")
LastRow = 17 'last row on both sheets
f = 1
g = 1
With w2
Lastcol_w2 = .Cells(3, Columns.Count).End(xlToLeft).Column
'array of dates in w2
ReDim arrDates_w2(1, Lastcol_w2)
End With
With w1
Lastcol_w1 = .Cells(3, Columns.Count).End(xlToLeft).Column
'Assign arrays:
ReDim arrAmounts(LastRow, Lastcol_w1)
ReDim arrDates_w1(1, Lastcol_w1)
For i = 1 To LastRow
For d = 1 To UBound(arrDates_w1, 2)
arrAmounts(i, d) = .Cells(3 + i, 2 + d)
Next
Next
'Match the dates in worksheets 1 and 2
For i = 1 To LastRow
For w = 1 To UBound(arrDates_w2, 2)
For d = 1 To UBound(arrDates_w1, 2)
If arrDates_w2(1, w) = arrDates_w1(1, d) Then
w2.Cells(i + 3, 2 + w) = arrAmounts(i, f + 3)
End If
Next
Next
Next
End With
End Sub
I would appreciate suggestions.
Please try this code.
Option Explicit
Sub CopyColumns()
Const CaptionRow As Long = 3 ' on all sheets
Const FirstClm As Long = 3 ' on all sheets
Dim WsIn As Worksheet ' Input sheet
Dim WsOut As Worksheet ' Output sheet
Dim DateRange As Range ' dates on WsIn
Dim Cin As Long ' input column
Dim Rl As Long ' last row in WsIn
Dim Cl As Long ' last used column in WsOut
Dim C As Long ' column counter in WsOut
Dim Arr As Variant ' transfer values
Set WsIn = Worksheets("Sheet1")
Set WsOut = Worksheets("Sheet2")
With WsIn
Set DateRange = .Range(.Cells(CaptionRow, FirstClm), .Cells(CaptionRow, .Columns.Count).End(xlToLeft))
End With
With WsOut
Cl = .Cells(CaptionRow, .Columns.Count).End(xlToLeft).Column
For C = FirstClm To Cl
On Error Resume Next
Cin = Application.Match(.Cells(CaptionRow, C).Value2, DateRange, 0)
If Err = 0 Then
Cin = Cin + DateRange.Column - 1
Rl = WsIn.Cells(WsIn.Rows.Count, Cin).End(xlUp).Row
Arr = WsIn.Range(WsIn.Cells(CaptionRow + 1, Cin), WsIn.Cells(Rl, Cin)).Value
.Cells(CaptionRow + 1, C).Resize(UBound(Arr)).Value = Arr
End If
Next C
End With
End Sub
What do you expect ReDim arrDates_w2(1, Lastcol_w2) to be doing? As it stands, it's only re-sizing the number of items that can be held in the array... You need to assign the Range to it: arrDates_w2 = w2.Range("C3:K3").Value for example. This will create a multi-dimensional array.
Then you can loop the items. Here's some sample code to illustrate the principle
Sub GetArrayInfo()
Dim a As Variant, i As Long, j As Long
Dim w2 As Worksheet
Set w2 = Sheets("Sheet2")
a = ws.Range("C3:K3").Value2
Debug.Print UBound(a, 1), UBound(a, 2)
For j = 1 To UBound(a, 2)
For i = 1 To UBound(a, 1)
Debug.Print a(i, j)
Next
Next
End Sub
Try
Sub test()
Dim Ws As Worksheet, Ws2 As Worksheet
Dim c As Integer, j As Integer, p As Integer
Dim i As Long, r As Long
Dim arr1() As Variant, arr2() As Variant
Dim rngDB As Range, rngHead As Range
Set Ws = Sheets("Sheet1")
Set Ws2 = Sheets("Sheet2")
With Ws
c = .Cells(3, Columns.Count).End(xlToLeft).Column
r = .Range("c" & Rows.Count).End(xlUp).Row
Set rngHead = .Range("c3", .Cells(3, c))
arr1 = .Range("c3", .Cells(r, c))
End With
With Ws2
c = .Cells(3, Columns.Count).End(xlToLeft).Column
Set rngDB = .Range("c3", .Cells(r, c))
arr2 = rngDB
End With
For j = 1 To UBound(arr2, 2)
p = WorksheetFunction.Match(arr2(1, j), rngHead, 0)
For i = 2 To UBound(arr2, 1)
arr2(i, j) = arr1(i, p)
Next i
Next j
rngDB = arr2
End Sub
I'm comparing some information contained in 2 different sheets. The validation is working as expected. From that comparison I have to get two values, it was working with one, because I was populating a 1D array. Now that I got a 2D array it doesn't seem to be getting populated and I can't figure why. Here is my code.
Private Sub btngenerar_Click()
Dim wscasos As Worksheet
Dim wstareas As Worksheet
Dim r1 As Range
Dim r2 As Range
Dim cel1 As Range
Dim cel2 As Range
Dim vrep As Integer
Dim i As Integer
Dim j As Integer
Dim flag As Integer
Dim resultado() As Variant
Dim x As Long
Set wscasos = ThisWorkbook.Worksheets("Filtrados")
Set wstareas = ThisWorkbook.Worksheets("Tareas")
With wscasos
Set r1 = .Range("B2", .Cells(.Rows.Count, .Columns("B:B").Column).End(xlUp))
End With
With wstareas
Set r2 = .Range("C2", .Cells(.Rows.Count, .Columns("C:C").Column).End(xlUp))
End With
On Error Resume Next
For Each cel1 In r1
With Application
Set cel2 = .Index(r2, .Match(cel1.Value, r2, 0))
If Err = 0 Then
vrep = .WorksheetFunction.CountIf(r2, cel1.Value)
For i = 1 To vrep
If cel2.Offset(i - 1, 4) = "Cerrado" Then
flag = flag + 1
Else
Exit For
End If
Next i
If flag = vrep Then
ReDim Preserve resultado(x, 1)
resultado(x, 0) = cel1.Value
resultado(x, 1) = cel1.Offset(, 8).Value
x = x + 1
End If
End If
Err.Clear
flag = 0
End With
Next cel1
i = 0
j = 0
Sheets("Reporte").Range("A1").Select
For i = LBound(resultado, 1) To UBound(resultado, 1)
For j = LBound(resultado, 2) To UBound(resultado, 2)
ActiveCell.Offset(i - 1, j - 1).Value = resultado(i, j)
Next j
Next i
End Sub
I'm a bit rusty and prolly it's a simple fix, I hope you can help me out to find the error. Thanks a lot in advance. Here is where I populate the array:
If flag = vrep Then
ReDim Preserve resultado(x, 1)
resultado(x, 0) = cel1.Value
resultado(x, 1) = cel1.Offset(, 8).Value
x = x + 1
End If
I am using Bloomberg sample code to collect data from Bloomberg through VBA (2d array?) and I have some old vba code that I believe takes a normal 3d array (maybe someone can clarify that for me). The problem is that Bloomberg output an array of elements.
See Bloomberg code below. Then below that is what I want to essentially convert the Bloomberg output into something that the next bit of code will accept.
Private Sub session_ProcessEvent(ByVal obj As Object)
On Error GoTo errHandler
Dim eventObj As blpapicomLib2.Event
Set eventObj = obj
If Application.Ready Then
If eventObj.EventType = PARTIAL_RESPONSE Or eventObj.EventType = RESPONSE Then
Dim it As blpapicomLib2.MessageIterator
Set it = eventObj.CreateMessageIterator()
Do While it.Next()
Dim msg As Message
Set msg = it.Message
Dim securityData As Element
Dim securityName As Element
Dim fieldData As Element
Set securityData = msg.GetElement("securityData")
Set securityName = securityData.GetElement("security")
Set fieldData = securityData.GetElement("fieldData")
Sheet1.Cells(currentRow, 4).Value = securityName.Value
Dim b As Integer
For b = 0 To fieldData.NumValues - 1
Dim fields As blpapicomLib2.Element
Set fields = fieldData.GetValue(b)
Dim a As Integer
Dim numFields As Integer
numFields = fields.NumElements
For a = 0 To numFields - 1
Dim field As Element
Set field = fields.GetElement(a)
Sheet1.Cells(currentRow, a + 5).Value = field.Name & " = " & field.Value
Next
currentRow = currentRow + 1
Next b
Loop
' skip a row for next security
currentRow = currentRow + 1
End If
End If
Exit Sub
errHandler:
MsgBox Err.Description
End Sub
This is the next bit of code I want the Bloomberg output to feed into.
Option Explicit
Dim Count() As Variant
Dim AdjCount() As Variant
Dim Rev() As Variant
Dim Conf() As Variant
Dim ncount() As Integer
Sub CreateSetupsBUY(series As Variant)
Dim x As Integer
Dim Y As Integer
Dim temp1 As Variant
Dim temp2 As Variant
Dim temp3 As Variant
Dim temp4 As Integer
Dim temp5 As Variant
ReDim Count(UBound(series))
ReDim AdjCount(UBound(series))
ReDim Rev(UBound(series))
ReDim Confn(UBound(series))
ReDim ncount(UBound(series))
For x = LBound(series) To UBound(series)
ReDim temp1(UBound(series(x)))
ReDim temp2(UBound(series(x)))
ReDim temp3(UBound(series(x)))
temp4 = 0
ReDim temp5(UBound(series(x)))
For Y = LBound(series(x)) + 5 To UBound(series(x))
If IsNumeric(series(x)(Y, 1)) Then
If series(x)(Y, 4) < series(x)(Y - 4, 4) Then
temp1(Y) = 1 + temp1(Y - 1)
Else
temp1(Y) = 0
End If
If series(x)(Y, 4) > series(x)(Y - 4, 4) Then
temp5(Y) = 1 + temp5(Y - 1)
Else
temp5(Y) = 0
End If
If temp1(Y) > 9 Then
temp2(Y) = 0
Else
temp2(Y) = temp1(Y)
End If
If temp1(Y) = 9 Then
temp4 = temp4 + 1
End If
If series(x)(Y - 1, 4) >= series(x)(Y - 5, 4) Then
temp3(Y) = 1
Else
temp3(Y) = 0
End If
Else
temp1(Y) = 0
temp2(Y) = 0
temp3(Y) = 0
temp4 = 0
temp5(Y) = 0
End If
Next Y
Count(x) = temp1
AdjCount(x) = temp2
Conf(x) = temp3
ncount(x) = temp4
Rev(x) = temp5
Next x
Call CreateCount(series, Count, Conf, ncount, Rev)
End Sub
When I tried connecting the two I get a type error. I assume its because of the way the Bloomberg array is created and unpacked.
Possible solution I have yet to try is to unpack the Bloomberg array and some how build a basic column row array while the Bloomberg array is unpacking.