i'm trying to fetch the Data from a PivotTable, use it in Array in VBA and then to print it. I'm new to VBA and I've watched a few tutorials, but i can't actually get it.
I've tried with referencing the range of my column with "DataBodyRange", but i always get different errors. "Sheet4" is the sheet where my "PivotTable1" is located. And i need all the data from a column.
Public Sub ReadToArray()
'Range
Dim rg As Range
Set rg = Worksheets("Sheet4").pt("PivotTable1").DataBodyRange
'Dynamic Array
Dim Done As Variant
Done = rg.Value
'Array Values
Debug.Print "i", "Value"
Dim i As Long
For i = LBound(Done) To UBound(Done)
Debug.Print i, Done(i)
Next i
End Sub
The end result is that I want to print out the values for the whole column and use them afterwards.
So I can see a few problems that are causing this. FIrst, to reference a pivot table in a sheet, you need .pivottables() not .pt().
Next, setting an array to have the value from a range like this will give you a 2D array, so you need to loop through it in two dimensions to get all the values. I've added a nested loop using a second iterator, j:
Public Sub ReadToArray()
Dim pt As PivotTable
Dim rg As Range
Set pt = Worksheets("Sheet4").PivotTables("PivotTable1")
Set rg = pt.DataBodyRange
Dim Done As Variant
Done = rg.Value
Debug.Print "i", "Value"
Dim i As Long, j As Long
For i = LBound(Done, 1) To UBound(Done, 1)
For j = LBound(Done, 2) To UBound(Done, 2)
Debug.Print i & ", " & j & ", " & Done(i, j)
Next j
Next i
End Sub
Related
I want to copy a range of cells (custom format) filled with time data (e.g. 8:00, 7:30, 5:45, ...) as text to write to another program through Application.SendKeys. When I grab the cells as they are, they're written out as e. g. 1.041666666 instead of 7:30. How do I copy or convert them to text? Trying to get the value/text from the whole range as I copy won't work, neither did attempts at looping through afterwards to change the values separately. There might be workarounds using clipboard, but I want to leave it untouched. Code right now:
DayArray = Application.ActiveSheet.Range("A1:E4")
For j = 1 To UBound(DayArray)
For k = 1 To 5 'fixed column count
DayArray(j, k)= DayArray(j, k).Text
Next k
Next j
(... SendKeys example)
Application.SendKeys DayArray(1, 1), True
Use the Format() Function. It returns a string in the format desired:
DayArray = Application.ActiveSheet.Range("A1:E4")
For j = 1 To UBound(DayArray)
For k = 1 To 5 'fixed column count
DayArray(j, k)= Format(DayArray(j, k),"h:mm")
Next k
Next j
Time Range to Strings in a 2D one-based Array
Try:
Dim ws As Worksheet: Set ws = ActiveSheet
Dim DayArray() As Variant: DayArray = ws.[TEXT(A1:E4,"h:mm")]
or just (for the ActiveSheet exclusively):
Dim DayArray() As Variant: DayArray = [TEXT(A1:E4,"h:mm")]
Or an Evaluate one-liner function...
Function GetTimeRange( _
ByVal rg As Range) _
As Variant
GetTimeRange = rg.Worksheet.Evaluate("TEXT(" & rg.Address & ",""h:mm"")")
End Function
... to be used e.g. in the following way:
Sub GetTimeRangeTEST()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim rg As Range: Set rg = ws.Range("A1:E4")
Dim Data As Variant: Data = GetTimeRange(rg)
ws.Range("G1").Resize(UBound(Data, 1), UBound(Data, 2)).Value = Data
End Sub
I currently have an array built to where I have all the columns I need to build a table. However, I am having trouble splitting up this array to match the according values.
In order to build this array, I am extracting the data from this table as seen in sheet2 labeled "Current Drawing Text"
Next, I am trying to build a new table based off of the data in sheet2 onto sheet sheet3 (labeled "Wire Checker"), this time using the cables to match which drawing number that they are on. This table currently looks something like this:
I have the array broken up by cable name. I just am unsure on how I would be performing the matches from the cables to the drawing number. I tried using formulas to "test", but without any luck. This is the code that I have tried so far:
Sub Searchalltest()
Dim WireCheckerWorksheet As Worksheet
Dim DrawingLastRow As Long
Dim CableLastRow As Long
Dim DrawingandCableRange As Range
Dim CurrentDrawingTextWorksheet As Worksheet
Dim DrawingTableArray
Dim DrawingNumber As Long
Dim CableNumber
Dim ArrayStart
Set WireCheckerWorksheet = ThisWorkbook.Worksheets("Wire Checker")
'Temporary Varaiables
Dim Row As Long
Row = 20
Dim Column_D As Integer
Column_D = 4
'End of Temporary variables
Dim dict As New Scripting.Dictionary
Set CurrentDrawingTextWorksheet = ThisWorkbook.Worksheets("Current Drawing Text")
DrawingLastRow = CurrentDrawingTextWorksheet.Range("C" & CurrentDrawingTextWorksheet.Rows.Count).End(xlUp).Row 'last row to be calculated for every drawing the entry
DrawingTableArray = CurrentDrawingTextWorksheet.Range("C20:G" & DrawingLastRow).Value
For DrawingNumber = 1 To UBound(DrawingTableArray) 'iterate between the array rows number:
ArrayStart = Split(DrawingTableArray(DrawingNumber, 5), vbLf) 'split the cells content on the line separator
For Each CableNumber In ArrayStart 'iterate between the splited array elements:
If Not dict.Exists(CableNumber) Then 'put the array elements in a dictionary (as unique keys)
dict.Add CableNumber, DrawingTableArray(DrawingNumber, 1) 'the item is the value in array col 1 (Group 1, 2, 3...)
Else
dict(CableNumber) = dict(CableNumber) & "|" & DrawingTableArray(DrawingNumber, 1) 'add to the key value the other Groups, separated by "|"
End If
Next CableNumber
Next DrawingNumber
Dim ArrayFinal
For Each CableNumber In dict
With Worksheets("Wire Checker")
Debug.Print CableNumber
.Cells(Row, Column_D).Value = CableNumber
Row = Row + 1
End With
Next
'Now let's sort the cables
Dim WireCheckerWorksheetCableLastRow As Long
WireCheckerWorksheetCableLastRow = Cells(Rows.Count, Column_D).End(xlUp).Row
Range("A20:D" & WireCheckerWorksheetCableLastRow).Sort key1:=Range("D20:D" & WireCheckerWorksheetCableLastRow), order1:=xlAscending, Header:=xlNo
End Sub
I am using an IF statement in Excel to search for portions of text in the previous column in order to assign a supplier and category to the expense.
Supplier Column
=IF(ISNUMBER(SEARCH("tit",[#Description])),"TITAN",IF(ISNUMBER(SEARCH("Sol",[#Description])),"Soltrack",IF(ISNUMBER(SEARCH("coin",[#Description])),"Coin",IF(ISNUMBER(SEARCH("gree",[#Description])),"Green Dream Projects",IF(ISNUMBER(SEARCH("sars V",[#Description])),"SARS VAT",IF(ISNUMBER(SEARCH("sars p",[#Description])),"SARS PAYE",IF(ISNUMBER(SEARCH("acb",[#Description])),"Debit Order","")))))))
Category Column
the next column then has the following to get the category of the supplier
=IF(ISNUMBER(SEARCH("TITAN",[#Payee])),"Direct Operating Cost",IF(ISNUMBER(SEARCH("Soltrack",[#Payee])),"Direct Operating Cost",IF(ISNUMBER(SEARCH("Coin",[#Payee])),"Direct Operating Cost",IF(ISNUMBER(SEARCH("Green Dream Projects",[#Payee])),"Direct Operating Cost",IF(ISNUMBER(SEARCH("SARS VAT",[#Payee])),"VAT",IF(ISNUMBER(SEARCH("SARS PAYE",[#Payee])),"PAYE",IF(ISNUMBER(SEARCH("Debit Order",[#Payee])),"Debit Order","")))))))
this is working great, but seems i have reached the limit (7) of IF statements I can use in one formula?
I have created the below function to search for text "tit" and if it matches it updates the Payee column.
'excel if range of cells contains specific text vba
Sub MacroToCheckIfRangeOfCellsContainsSpecificText_vba()
Set Rng = Range("B2:B572") ' You can change this
specificText = "*tit*" ' You can change this
For Each Cell In Rng.Cells
If UCase(Cell.Value) Like "*" & UCase(specificText) & "*" Then
Cell.Offset(0, 1) = "Titan"
Else
Cell.Offset(0, 1) = ""
End If
Next
End Sub
Would I need to create a new specificText = "*tit*" for each of the keywords and also a whole section for each of the "For Each" functions?
Dictionary Solution
The first idea is to use a dictionary Replacements and add all the serach/replace pairs there. This has one huge disadvantage. It is against the good practice to not mix logic (code) and data. Good practice would be to put the data not into the code but into a worksheet (see next solution).
Option Explicit
Public Sub MacroToCheckIfRangeOfCellsContainsSpecificText_vba()
Dim RngToCheck As Range
Set RngToCheck = ThisWorkbook.Worksheets("Sheet1").Range("B2:B572") ' specify in which workbook and worksheet
Dim Replacements As Object
Set Replacements = CreateObject("Scripting.Dictionary")
With Replacements
.Add "tit", "Titan"
.Add "sol", "Soltrack"
'add more here
End With
Dim InputValues() As Variant
InputValues = RngToCheck.Value 'read input values into array
Dim OutputValues() As Variant 'create an output array (same size as RngToCheck)
ReDim OutputValues(1 To RngToCheck.Rows.Count, 1 To 1)
Dim iRow As Long
For iRow = 1 To UBound(OutputValues, 1)
Dim Key As Variant
For Each Key In Replacements.Keys
If UCase(InputValues(iRow, 1)) Like "*" & UCase(Key) & "*" Then
OutputValues(iRow, 1) = Replacements(Key)
Exit For 'we don't need to test for the others if we found a key
End If
Next Key
Next iRow
'write output values from array next to input values in the cells
RngToCheck.Offset(ColumnOffset:=1).Value = OutputValues
End Sub
Worksheet Solution
The better solution would be to create a new worksheet Replacements as below:
This can easily be edited by anyone and you don't need to fiddle with the code later if you want to delete or add pairs.
Public Sub ImprovedCheckUsingWorksheet()
Dim RngToCheck As Range
Set RngToCheck = ThisWorkbook.Worksheets("Sheet1").Range("B2:B572") ' specify in which workbook and worksheet
Dim Replacements() As Variant 'read replacements from worksheet
Replacements = ThisWorkbook.Worksheets("Replacements").Range("A2", ThisWorkbook.Worksheets("Replacements").Cells(Rows.Count, "B").End(xlUp)).Value 'read input values into array
Dim InputValues() As Variant
InputValues = RngToCheck.Value 'read input values into array
Dim OutputValues() As Variant 'create an output array (same size as RngToCheck)
ReDim OutputValues(1 To RngToCheck.Rows.Count, 1 To 1)
Dim iRow As Long
For iRow = 1 To UBound(OutputValues, 1)
Dim rRow As Long
For rRow = 1 To UBound(Replacements, 1)
If UCase(InputValues(iRow, 1)) Like "*" & UCase(Replacements(rRow, 1)) & "*" Then
OutputValues(iRow, 1) = Replacements(rRow, 2)
Exit For 'we don't need to test for the others if we found a key
End If
Next rRow
Next iRow
'write output values from array next to input values in the cells
RngToCheck.Offset(ColumnOffset:=1).Value = OutputValues
End Sub
For a 3ʳᵈ column in your replacements worksheet you would need to adjust the following line to be until column "C":
Replacements = ThisWorkbook.Worksheets("Replacements").Range("A2", ThisWorkbook.Worksheets("Replacements").Cells(Rows.Count, "C").End(xlUp)).Value 'read input values into array
and the output values need another column too (second parameter needs to go 1 To 2):
ReDim OutputValues(1 To RngToCheck.Rows.Count, 1 To UBound(Replacements, 2) - 1) 'this works for any amount of columns as it reads the column count from the `Replacements`
the data needs to be written
OutputValues(iRow, 1) = Replacements(rRow, 2) 'first output column
OutputValues(iRow, 2) = Replacements(rRow, 3) 'second output column
and writing the output values needs to be adjusted too:
RngToCheck.Offset(ColumnOffset:=1).Resize(ColumnSize:=UBound(OutputValues, 2)).Value = OutputValues 'this works for any amount of columns as it reads the column count from `OutputValues`
Formula Solution
But if you have your data in a worksheet Replacements like above, and you don't rely an a partial match. Then you don't need VBA and can easily use a formula instead to look it up:
=IFERROR(INDEX(Replacements!B:B,MATCH(B:B,Replacements!A:A,0)),"")
Using VBA, I would like to AND across each row in a 2D array and star the result in separate 1D array without ANDing a single pair the ANDing the result with the next item in that row.
FYI This is my first time using 2D arrays so sorry if there is an obvious solution.
For example if the data in my sheet looked like this (the actual range is much larger):
I would like to do the equlavant of an excel formula: =AND(B2:D2) then =AND(B3:D3), etc...
I have code that sets everything up but I don't know how to proceed except to loop across each element of a row, store the result then loop across the next, etc, etc. I'm hoping the there is a much better (more efficient) way to proceed.
Here is my code so far
Sub Exceptions()
' Setup worksheet
Dim wks As Worksheet
Set wks = cnTest
' Find last row of range
Dim LastRow As Long
LastRow = Find_LastRow(wks) 'Functionthat returns last row
' load range into array
Dim MyArray As Variant
MyArray = wks.Range("B2:D8")
' Setup 1D Result array
Dim Results As Variant
Results = wks.Range("A2:A8")
Dim i As Long
For i = 1 To LastRow
' Perform AND function on each row of the array
' then place result in 1D array (Results())
' If this were a formul: =AND(B2:D2)
'
' Is there way to "AND" across a row in and array or
' must I "AND" MyArray(1,1) with MyArray(1,2) then AND
' that result with MyArray(1,3)
Next i
End Sub
Thank you
Try this.
Sub Exceptions()
' Setup worksheet
' load range into array
Dim MyArray As Variant
MyArray = ActiveSheet.Range("B2:D8")
' Setup 1D Result array
Dim Results As Variant
Results = ActiveSheet.Range("A2:A8")
Dim i As Long
Dim X As Long
For i = 1 To UBound(MyArray, 1)
Results(i, 1) = "True"
For X = 1 To UBound(MyArray, 2)
If MyArray(i, X) = False Then
Results(i, 1) = "False"
Exit For
End If
Next X
Next i
End Sub
Try,
Sub test()
Dim vR()
Dim rngDB As Range, rng As Range
Dim i As Long, r As Long
Set rngDB = Range("b2:b8")
r = rngDB.Rows.Count
ReDim vR(1 To r)
For Each rng In rngDB
i = i + 1
vR(i) = WorksheetFunction.And(rng.Resize(1, 3))
Next rng
Range("a2").Resize(r) = WorksheetFunction.Transpose(vR)
End Sub
In the formula bar, type:
=IF(-PRODUCT(IF(A1,-1,0),IF(C1,-1,0)),TRUE,FALSE)
(if the data is in columns A and C), and drag down.
Because, as everyone knows, A AND B = AB if A and B are Boolean variables (and watch the minus in front of the PRODUCT).
I have a worksheet with data in columns A and B.
I am looking for a convenient way to take these columns and convert to dictionary where the cell in column A is the key and column B is the value, something like :
Dim dict as Dictionary
Set dict = CreateDictFromColumns("SheetName", "A", "B")
NOTE: I am already referencing the scripting dll.
You would need to loop, E.g.
Function CreateDictFromColumns(sheet As String, keyCol As String, valCol As String) As Dictionary
Set CreateDictFromColumns = New Dictionary
Dim rng As Range: Set rng = Sheets(sheet).Range(keyCol & ":" & valCol)
Dim i As Long
Dim lastCol As Long '// for non-adjacent ("A:ZZ")
lastCol = rng.Columns.Count
For i = 1 To rng.Rows.Count
If (rng(i, 1).Value = "") Then Exit Function
CreateDictFromColumns.Add rng(i, 1).Value, rng(i, lastCol).Value
Next
End Function
This breaks on the first empty key value cell.
I think it'd be best form to pass two ranges to a create dictionary function. This allows for the ranges to be completely separate, even different workbooks. It also allows for a 1D range to be mapped to a 2D range as demonstrated below.
Alternatively, you could also pass two arrays of range values. That may be cleaner for 1D ranges, but would result in slightly more code for 2D mapping. Notice that range elements can be looped through left to right top to bottom by index. You can use Application.Transpose(Range("A1:A5")) to effectively run top to bottom left to right.
Jagged Mapping
Sub Test()
RangeToDict Sheets(1).Range("A1:A5"), Sheets(2).Range("C1:E2")
End Sub
Function RangeToDict(ByVal KeyRng As Range, ByVal ValRng As Range) As Dictionary
Set RangeToDict = New Dictionary
For Each r In KeyRng
vi = vi + 1
'It may not be advisable to handle empty key values this way
'The handling of empty values and #N/A/Error values
'Depends on your exact usage
If r.Value2 <> "" Then
RangeToDict.Add r.Value2, ValRng(vi)
Debug.Print r.Value2 & ", " & ValRng(vi)
End If
Next
End Function
Side-By-Side (As Range)
If your target range is a single 2 column range side by side, you can simplify to passing a single range as shown below. Consequently, this also works for mapping every other element in a 1 dimensional range.
Sub Test()
RangeToDict2 Range("A1:B5")
End Sub
Function RangeToDict2(ByVal R As Range) As Dictionary
Set RangeToDict2 = New Dictionary
i = 1
Do Until i >= (R.Rows.Count * R.Columns.Count)
RangeToDict2.Add R(i), R(i + 1)
Debug.Print R(i) & ", " & R(i + 1)
i = i + 2
Loop
End Function
Two Columns (As Array)
Lastly, as an example of passing arrays as arguments, you could do something like the following. However, the following code will only work given the OP's specific scenario of mapping two columns. As is, it won't handle mapping rows or alternating elements.
Sub Test()
Dim Keys() As Variant: Keys = Range("E1:I1").Value2
Dim Values() As Variant: Values = Range("E3:I3").Value2
RangeToDict Keys, Values
End Sub
Function RangeToDict(Keys() As Variant, Values() As Variant) As Dictionary
Set RangeToDict = New Dictionary
For i = 1 To UBound(Keys)
RangeToDict.Add Keys(i, 1), Values(i, 1)
Debug.Print Keys(i, 1) & ", " & Values(i, 1)
Next
End Function
Use of Named Ranges
It may be convenient to used named ranges, in which case you can pass a Range as an argument likes this...
Sub Test()
RangeToDict Names("Keys").RefersToRange, Names("Values").RefersToRange
End Sub
The best approach to take, is to populate a variant array with the data from the worksheet. You can then loop through the array, assigning the elements of the first array column as the dictionary key; the elements of the second array column can then be used as the value.
The lrow function is used to find the last populated row from column A - allowing the code to create a dynamically sized array and dictionary.
To enable use of dictionaries within VBA, you will need to go to Tools -> References and then enable Microsoft Scripting Runtime.
Sub createDictionary()
Dim dict As Scripting.Dictionary
Dim arrData() As Variant
Dim i as Long
arrData = Range("A1", Cells(lrow(1), 2))
set dict = new Scripting.Dictionary
For i = LBound(arrData, 1) To UBound(arrData, 1)
dict(arrData(i, 1)) = arrData(i, 2)
Next i
End Sub
Function lrow(ByVal colNum As Long) As Long
lrow = Cells(Rows.Count, 1).End(xlUp).Row
End Function
This should do the trick :
Public Function test_leora(SheetName As String, _
KeyColumn As String, _
ValColumn As String) _
As Variant
Dim Dic, _
Val As String, _
Key As String, _
Ws As Worksheet, _
LastRow As Long
Set Ws = ThisWorkbook.Sheets(SheetName)
Set Dic = CreateObject("Scripting.Dictionary")
With Ws
LastRow = .Range(KeyColumn & .Rows.Count).End(xlUp).Row
For i = 1 To LastRow
Val = .Cells(i, ValColumn)
Key = .Cells(i, KeyColumn)
If Dic.exists(Key) Then
Else
Dic.Add Key, Val
End If
Next i
End With
test_leora = Dic
End Function