I have two named ranges I want to join, ie append the 2nd range onto the end of the first one in an array. When I use Union I only get the first range in the array. If I just use Range it works but I can't join non-contiguous ranges.
Sub GetAbilities()
Dim Arr() As Variant
Dim rng1 As Range
Dim rng2 As Range
Dim newRng As Range
Set rng1 = tbl.ListColumns("Ability1").DataBodyRange
Set rng2 = tbl.ListColumns("Ability2").DataBodyRange
Set newRng = Union(rng1, rng2)
' Set newRng = Range(rng1, rng2)
' This works fine
Arr = newRng
Dim Destination As Range
Set Destination = Sheets("test").Range("A1")
Destination.Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr
End Sub
You are just stacking two columns on top of each other I think so you can loop as follows:
Option Explicit
Sub Test()
Dim Arr() As Variant
Dim tbl As ListObject
Set tbl = ThisWorkbook.Worksheets("Sheet4").ListObjects("Table1") 'this would be set as per your requirements
Dim totalOutputRows As Long
Dim totalColumnRows As Long
totalColumnRows = tbl.DataBodyRange.Rows.Count
totalOutputRows = totalColumnRows * 2
ReDim Arr(1 To totalOutputRows)
Dim i As Long
Dim j As Long
For i = 1 To totalOutputRows
If i <= totalColumnRows Then
Arr(i) = tbl.ListColumns("Ability1").DataBodyRange(i, 1)
Else
j = j + 1
Arr(i) = tbl.ListColumns("Ability2").DataBodyRange(j, 1)
End If
Next i
End Sub
You could also get rid of j and just put
Arr(i) = tbl.ListColumns("Ability2").DataBodyRange(i - totalColumnRows, 1)
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.
I have a code that copies data from different workbooks to an array and transfers that data to a table I want to keep the filter method with a slicer on the workbook I copy that data from but to copy only the filtered data.
on the workbook I am copying to I want only the filtered that to be seen
Does anyone have suggestions?
I commented out the offset because the code doesn't work i need the offset in order not to copy the header row
Sub readingarray()
Dim table_list_object As ListObject
Dim table_object_row As ListRow
Dim arr As Variant
Dim tbl As Range
Set tbl = Workbooks("test.xlsm").Worksheets("shibuz").Range("T4").CurrentRegion.SpecialCells(xlCellTypeVisible)
'arr = tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, tbl.Columns.Count)
arr = tbl
Set table_list_object = Workbooks("shibuzim 2 updated.xlsm").Worksheets("shibuz").ListObjects("LeaveTracker")
Set table_object_row = table_list_object.ListRows.Add
Dim rowcount As Long, columncount As Long
rowcount = UBound(arr, 1)
columncount = UBound(arr, 2)
table_object_row.Range(1, 1).Resize(rowcount, columncount).Value = arr
End Sub
solved it, hopes this might help
Option Explicit
Sub readingarray()
Application.DisplayAlerts = False
Dim table_list_object As ListObject
Dim table_object_row As ListRow
Dim arr
Dim Itm
Dim rng As Range
Dim stringarray As Variant
Dim rowcount As Long, columncount As Long
stringarray = Array("test.xlsm", "test 2.xlsm")
On Error Resume Next
For Each Itm In stringarray
arr = GetArrayFromFilteredRange(Workbooks(Itm).Worksheets("shibuz").ListObjects("LeaveTracker").DataBodyRange.SpecialCells(xlCellTypeVisible))
Set table_list_object = Workbooks("shibuzim 2 updated.xlsm").Worksheets("shibuz").ListObjects("LeaveTracker")
Set table_object_row = table_list_object.ListRows.Add
rowcount = UBound(arr, 1)
columncount = UBound(arr, 2)
table_object_row.Range(1, 1).Resize(rowcount - 1, columncount - 1).Value = arr
Next Itm
On Error GoTo 0
End Sub
Function GetArrayFromFilteredRange(rng As Range) As Variant
Dim arr As Variant
helper.Cells.Clear
rng.Copy helper.Range("A1")
arr = helper.UsedRange.Value
GetArrayFromFilteredRange = arr
End Function
I'm trying to sum numbers that are in an array.
I get the attached error message.
What is the syntax for using Sumif within an array?
Sub SumNumbers()
Dim arr As Variant
arr = Range("A1").CurrentRegion.Value
Dim iMax As Long
iMax = UBound(arr, 1)
Debug.Print WorksheetFunction.SumIf(Range(arr(1, 1), arr(iMax, 1)), "A", Range(arr(1, 2), arr(iMax, 2)))
End Sub
SumIf function works on ranges... At least its first parameter must be a range.
Please, try the next code:
Sub testSumif()
Dim sh As Worksheet, rngB As Range, rngC As Range, lastRow As Long
Set sh = ActiveSheet 'use here the sheet you need
lastRow = sh.Range("B" & sh.Rows.count).End(xlUp).row
Set rngB = sh.Range("B2:B" & lastRow)
Set rngC = sh.Range("C2:C" & lastRow)
Debug.Print WorksheetFunction.SumIf(rngB, "A", rngC)
End Sub
If you insist to use the CurrentRegion, try the next code, please:
Sub testSumifBis()
Dim sh As Worksheet, rng As Range, rngB As Range, rngC As Range
Set sh = ActiveSheet 'use here the sheet you need
Set rng = sh.Range("B2").CurrentRegion
Set rngB = rng.Columns(1)
Set rngC = rng.Columns(2)
Debug.Print WorksheetFunction.SumIf(rngB, "A", rngC)
End Sub
Sumif vs Loop vs Match'n'Loop
I would use the first solution.
The Code
Option Explicit
Sub sumIfRange()
Dim rg As Range
' Define Current Region range.
Set rg = Range("A1").CurrentRegion
' Only use data from 'A2' to 'Bwhatever' (no headers).
Set rg = rg.Resize(rg.Rows.Count - 1).Offset(1)
Dim Result As Double
Result = Application.SumIf(rg.Columns(1), "A", rg.Columns(2))
Debug.Print Result
End Sub
Sub sumIfLoop()
Dim rg As Range
' Define Current Region range.
Set rg = Range("A1").CurrentRegion
' Only use data from 'A2' to 'Bwhatever' (no headers).
Set rg = rg.Resize(rg.Rows.Count - 1).Offset(1)
' Only now write to array.
Dim Data As Variant: Data = rg.Resize(, 2).Value
Dim Result As Double
Dim i As Long
Dim j As Long
For i = 1 To UBound(Data, 1)
If Not IsError(Data(i, 1)) Then
If Data(i, 1) = "A" Then
If IsNumeric(Data(i, 2)) Then
Result = Result + Data(i, 2)
End If
End If
End If
Next i
Debug.Print Result
End Sub
Sub sumIfMatchLoop()
Dim rg As Range
' Define Current Region range.
Set rg = Range("A1").CurrentRegion
' Only use data from 'A2' to 'Bwhatever' (no headers).
Set rg = rg.Resize(rg.Rows.Count - 1).Offset(1)
' Only now write to arrays.
Dim lData As Variant: lData = rg.Columns(1).Value
Dim rData As Variant: rData = rg.Columns(2).Value
Dim mData As Variant: mData = Application.Match(lData, Array("A"), 0)
Erase lData
Dim Result As Double
Dim i As Long
For i = 1 To UBound(mData)
If IsNumeric(mData(i, 1)) Then
Result = Result + rData(i, 1)
End If
Next i
Debug.Print Result
End Sub
I have multiple worksheets with ranges which I collect into an array of ranges, and I cant do Union since it does not work across worksheets.
Since I want to create a chart where the time-series or FullSeriesCollection are based on the elements of my combined ranges, I thought that redimensioning the array of ranges into a single array might serve as my solution.
Perhaps there is an easier solution that I am not seeing.
I tried to outline the general case below. The ranges are dynamic in my code, but here I just set them arbitrarily.
Sub Collection()
Dim arrDate() As Variant
Dim arrRngTotal As Variant
Dim rng_1 As Range, rng_2 As Range, rng_3 As Range
Dim ws_1 As Worksheet, ws_2 As Worksheet
Dim j As Integer, k As Integer
Set ws_1 = ThisWorkbook.Sheets(1)
Set ws_2 = ThisWorkbook.Sheets(2)
' Example of ranges, not static in the original code.
Set rng_1 = ws_1.Range("A2:A10")
Set rng_2 = ws_1.Range("A11:A22")
Set rng_3 = ws_2.Range("A2:A22")
arrRngTotal = Array(rng_1.Value, rng_2.Value, rng_3.Value)
For k = LBound(arrRngTotal, 1) To UBound(arrRngTotal, 1)
For j = LBound(arrRngTotal(k), 1) To UBound(arrRngTotal(k), 1)
ReDim Preserve arrDate(j)
arrDate(j) = arrRngTotal(k)(j, 1)
Next j
Next k
End Sub
When I use this code I get an array with 22 elements corresponding to the range of rng_3. What I want to end up with after the nested loop is an array that contains the elements from all ranges in 1 single array with 1 dimension.
The reason I want this in the end is I want to create chart using the array values.
Your code is fine, the only error is that you are reusing the same variable from your inner loop, which would reset on each outer loop. To get around that, just use an additional variable as such:
Sub Collection()
Dim arrDate() As Variant
Dim arrRngTotal As Variant
Dim rng_1 As Range, rng_2 As Range, rng_3 As Range
Dim ws_1 As Worksheet, ws_2 As Worksheet
Dim j As Integer, k As Integer, X As Long
Set ws_1 = ThisWorkbook.Sheets(1)
Set ws_2 = ThisWorkbook.Sheets(2)
' Example of ranges, not static in the original code.
Set rng_1 = ws_1.Range("A2:A10")
Set rng_2 = ws_1.Range("A11:A22")
Set rng_3 = ws_2.Range("A2:A22")
arrRngTotal = Array(rng_1.Value, rng_2.Value, rng_3.Value)
For k = LBound(arrRngTotal, 1) To UBound(arrRngTotal, 1)
For j = LBound(arrRngTotal(k), 1) To UBound(arrRngTotal(k), 1)
X = X + 1 'Add an additional counter
ReDim Preserve arrDate(X)
arrDate(X) = arrRngTotal(k)(j, 1)
Next j
Next k
End Sub
EDIT: slight variation, to improve the speed as per #Tom suggestion... see comments for further details.
Sub Collection()
Dim arrDate() As Variant: ReDim arrDate(1 To 1)
Dim arrRngTotal As Variant
Dim rng_1 As Range, rng_2 As Range, rng_3 As Range
Dim ws_1 As Worksheet, ws_2 As Worksheet
Dim j As Integer, k As Integer, X As Long
Set ws_1 = ThisWorkbook.Sheets(1)
Set ws_2 = ThisWorkbook.Sheets(1)
' Example of ranges, not static in the original code.
Set rng_1 = ws_1.Range("A2:A10")
Set rng_2 = ws_1.Range("A11:A22")
Set rng_3 = ws_2.Range("A2:A22")
arrRngTotal = Array(rng_1.Value, rng_2.Value, rng_3.Value)
'Dimension the holding array outside the main data loop, unless you need to do this inside based on various conditions
For k = LBound(arrRngTotal, 1) To UBound(arrRngTotal, 1)
X = X + UBound(arrRngTotal(k))
Next k
ReDim Preserve arrDate(1 To X): X = 0
For k = LBound(arrRngTotal, 1) To UBound(arrRngTotal, 1)
For j = LBound(arrRngTotal(k), 1) To UBound(arrRngTotal(k), 1)
X = X + 1
arrDate(X) = arrRngTotal(k)(j, 1)
Next j
Next k
End Sub
This should work for you:
Option Explicit
Sub Collection()
Dim arrDate As Variant
Dim ws_1 As Worksheet, ws_2 As Worksheet
Dim LastRow As Long, j As Long
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Set ws_1 = ThisWorkbook.Sheets(1)
Set ws_2 = ThisWorkbook.Sheets(2)
With ThisWorkbook
.Sheets.Add After:=.Sheets(.Sheets.Count)
End With
With ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
.Range("A1").Resize(ws_1.Range("A2:A10").Rows) = ws_1.Range("A2:A10").Value
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Range("A" & LastRow).Resize(ws_1.Range("A11:A22").Rows) = ws_1.Range("A11:A22").Value
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Range("A" & LastRow).Resize(ws_2.Range("A2:A22").Rows) = ws_2.Range("A2:A22").Value
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
j = 1
ReDim arrDate(1 To LastRow)
For Each C In .Range("A1:A" & LastRow)
arrDate(j) = C
Next C
.Delete
End With
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
You can use the following to combine all arrays into one
Sub Collection()
Dim arrDate() As Variant
Dim arrRngTotal As Variant
Dim rng_1 As Range, rng_2 As Range, rng_3 As Range
Dim ws_1 As Worksheet, ws_2 As Worksheet
Dim j As Long, k As Long, arrCounter As Long
Set ws_1 = ThisWorkbook.Sheets(1)
Set ws_2 = ThisWorkbook.Sheets(2)
' Example of ranges, not static in the original code.
Set rng_1 = ws_1.Range("A2:A10")
Set rng_2 = ws_1.Range("A11:A22")
Set rng_3 = ws_2.Range("A2:A22")
With Application
arrRngTotal = Array(.Transpose(rng_1.Value), .Transpose(rng_2.Value), .Transpose(rng_3.Value))
End With
For k = LBound(arrRngTotal) To UBound(arrRngTotal)
On Error Resume Next
arrCounter = IIf(IsNumeric(UBound(arrDate)), UBound(arrDate), 0)
arrCounter = arrCounter + GetArraySize(arrRngTotal(k))
On Error GoTo 0
ReDim Preserve arrDate(1 To arrCounter)
For j = LBound(arrRngTotal(k)) To UBound(arrRngTotal(k))
Debug.Print UBound(arrDate) - (UBound(arrRngTotal(k)) - j), arrRngTotal(k)(j)
arrDate(UBound(arrDate) - (UBound(arrRngTotal(k)) - j)) = arrRngTotal(k)(j)
Next j
Next k
End Sub
Private Function GetArraySize(arr As Variant) As Long
GetArraySize = UBound(arr) - LBound(arr) + 1
End Function
I have a column with different values. I have to select only unique values from the column and put in an array.
I am using following code for the same but it puts unique values in another column rather array.
Sub GetUniqueSections()
Dim d As Object, c As Variant, i As Long, lastRow As Long
Dim a(8) As String
Dim j
Set d = CreateObject("Scripting.Dictionary")
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
c = Range("C2:C" & lastRow)
For i = 1 To UBound(c, 1)
d(c(i, 1)) = 1
Next i
Range("R2").Resize(d.Count) = Application.Transpose(d.Keys)
End Sub
In the code below, UniqueValueArrayFromRange replaces your GetUniqueSections using the same technique with a Scripting.Dictionary. You can substitute "A1:A14" with whatever you need and the output array will be in arr:
Option Explicit
Sub Test()
Dim rng As Range
Dim arr As Variant
Dim i As Integer
' pass range values to function for unique values
Set rng = Sheet1.Range("A1:A14")
arr = UniqueValueArrayFromRange(rng)
' test return values
For i = LBound(arr) To UBound(arr)
Debug.Print arr(i)
Next i
End Sub
Function UniqueValueArrayFromRange(ByRef rngSource As Range) As Variant
Dim dic As Object
Dim rngCell As Range
' create dictionary and only add new values
Set dic = CreateObject("Scripting.Dictionary")
For Each rngCell In rngSource
If Not dic.Exists(rngCell.Value) Then
dic.Add rngCell.Value, 1
End If
Next rngCell
' return key collection as array
UniqueValueArrayFromRange = dic.Keys
End Function