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)),"")
Related
The task at hand:
I have 2 tables: one that needs to be filled with the data from the mastersheet and the mastersheet. Examples below:
I need to copy the data from the green sheet and, based on the date and specific text on line and column, to paste it into the white sheet in the correct columns and skip the incorrect ones. the delta line just calculates the differences between the mastersheet and evidence cells.
Until now i tried multiple formulas such as vlookup after the date in the white, but it grabs just the numbers from method 1, and if i use something like =if(and(A2=":\green.xlsx[sheet1]"A2; b2="mastersheet"; C1="method1"), ":\green.xlsx[sheet1]"C2; " "), and vlookups that grabs only the data for the method1 (but it does it correctly)
Tried to write a macro in vba and here is one of the problems: it returns runtime error 52. Code below:
Sub GrabFillData()
'declaring variables and explaining each one role
Dim path As String
Dim newfo As Workbook 'newfo is the newly opened workbook
Dim newfows As Sheets 'newfows is a speciffied sheet to copy data from
With Application.FileDialog(msoFileDialogOpen)
.Show
If .SelectedItems.Count = 1 Then
path = .SelectedItems(1)
End If
End With
If path <> "" Then
Open path For Output As #n ' runtime error 52
End If
The same error i get when i use
Sub GetPath()
Dim path As String
path = InputBox("Enter a file path", "Title Here")
Open path For Output As #1
Close #1
End Sub
Another problem is that i thought i knew how to make the conditions for the copy-paste actions and i need a little help with that.
The macro will be running from the white sheet.
If there any formula that can make this easier?
Please, try the next code to process the two sheets as (I understood) you need. You did not answer my last clarification questions and the code assumes that maximum number of methods is 4 and unique occurrences exist for each such method. Using arrays and working mostly in memory, the code should be very fast, even for large ranges. It will return in "H2" all processed range. If you like the return, you should replace "H2" with "A2" in the last code line:
Sub ProcessPayments()
Dim shT As Worksheet, lastRT As Long, shM As Worksheet, lastRM As Long, dict As Object
Dim arr, arrInt, arrT, i As Long, j As Long, k As Long, arrMeth, mtch
arrMeth = Split("method1,method2,method3,method4", ",")
Set shT = ActiveSheet 'the white sheet
lastRT = shT.Range("A" & shT.rows.count).End(xlUp).row 'last row in A:A
arrT = shT.Range("A2:F" & lastRT).value 'place the range in an array for faster iteration
Set shM = shT.Next ' use here the master sheet you need
lastRM = shM.Range("A" & shM.rows.count).End(xlUp).row 'last row in A:A
arr = shM.Range("A2:C" & lastRM).value 'place the range in an array for faster iteration
Set dict = CreateObject("Scripting.Dictionary") 'set the dictionary
For i = 1 To UBound(arr) 'iterate between the array rows and place the necessary values in dictionary
If Not dict.Exists(arr(i, 1)) Then 'when the dictionary key does not exist, add a dictionary key as the Date value:
dict.Add arr(i, 1), Array(Array(arr(i, 2), arr(i, 3))) 'place the item as an array of two elements (method and value)
Else 'if the key exists, it add another element in the jagged array containing method ad value
arrInt = dict(arr(i, 1)): ReDim Preserve arrInt(UBound(arrInt) + 1) 'redim the existing array item with one element
arrInt(UBound(arrInt)) = Array(arr(i, 2), arr(i, 3)) 'place another array of two in the last added element
dict(arr(i, 1)) = arrInt 'place the intermediary array back to dictionary
End If
Next i
'Put the necessary data in the white sheet fields:
For i = 1 To UBound(arrT) 'iterate between the array elements:
If arrT(i, 2) = "mastersheet" Then 'for the rows having "mastersheet" in the second column:
For j = 0 To dict.count - 1 'iterate between the dictionary keys:
If arrT(i, 1) = dict.Keys()(j) Then 'when the dictionary key has been found:
For k = 0 To UBound(dict.items()(j)) 'Iterate between each array of the jag array item:
'match the array first item (method) in arrMeth (to set the column where to place the value):
mtch = Application.match(dict.items()(j)(k)(0), arrMeth, 0)
arrT(i, mtch + 2) = dict.items()(j)(k)(1) 'place the value in the appropriate column (the second array element)
Next k
End If
Next j
End If
Next i
'Place back the processed array, but not in "A2", only to check if its return is convenient and drop its content in "H2".
'If convenient, please replace "H2" whith "A2"
shT.Range("H2").Resize(UBound(arrT), UBound(arrT, 2)).value = arrT
End Sub
I could not understand from your question if the two involved sheets belong to the same workbook. The above code works with sheets from different workbooks/worksheets, too. You should take care to correctly set shM. Now it is the next sheet after the white one...
If you need to let the code opening the workbook using a dialog, this should be piece of cake. You already received answer(s) for this simple parte, I think...
I tried commenting each code line. If something not so clear, do not hesitate to ask for clarifications. But after testing it...
If you can change the column names in white sheet to "method1", "method2",...
OR
If you can change the row values in green sheet to "payment1", "payment2",...
Then you can use a complex INDEX MATCH function.
Follow the link below.
https://i.stack.imgur.com/xxACM.png
Using VBA there are a couple of thing with your code.. let's go 1 by 1.
Dim wb As Workbook, path As String
'You can use FileDialogFilePicker instead
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False 'Forces to choose 1 file.
If .Show = -1 Then 'Checks if OK button was clicked.
path = .SelectedItems(1)
End If
End With
'Use Workbooks.Open method instead of Open.
Set wb = Workbooks.Open(path)
Copy Pasting is easy.
Range("A1").Copy
Range("B5").PasteSpecial xlPasteValues 'Paste from A1 to B5
Sub GrabFillData()
'declaring variables and explaining each one role
Dim path As String
Dim newfo As Excel.Workbook 'newfo is the newly opened workbook
Dim Cell_1 As String ' Cell_1 refer to one cell in workbook
Dim newfows As Integer 'newfows is a speciffied sheet to copy data from
newfows = ActiveSheet.Index
With Application.FileDialog(msoFileDialogOpen)
.Show
If .SelectedItems.Count = 1 Then
path = .SelectedItems(1)
End If
End With
If path <> "" Then
'Open path For Output As #n ' runtime error 52
Set newfo = Excel.Application.Workbooks.Open(path) ' connect to workbook
Cell_1 = newfo.Sheets(newfows).Cells(2, 2) ' retrieve value of selected cell to string variable
End If
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 have a spreadsheet that contains over 100k rows in a single column (I know crazy) and I need to find an efficient way to highlight partial duplicates and remove them. All the records are all in the same format, but may have an additional letter attached at the end. I would like to keep the first instance of the partial duplicate, and remove all instances after.
So from this:
1234 W
1234 T
9456 S
1234 T
To This:
1234 W
9456 S
I was going to use the formula below to conditionally highlight the partial dupes, but i receive an error "You may not use reference operators (such as unions....) or array constants for Conditional Formatting criteria" and use VBA to remove those highlighted cells.
=if(A1<>"",Countif(A$1:A,left(A1,4)& "*") > 1)
Any thoughts? I know conditional formatting is memory intensive, so if there's any way to perform this using VBA I'm open to suggestion.
Here is one way to remove the duplicates quickly:
Text to Columns, using space delimiter.
Remove Duplicates referring to duplicates in the first column only.
Merge the content of each row with =Concatenate(A1, B1).
If the "unique identifier" of each value is just its first 4 characters, then maybe the code below will be okay for you.
I recommend making a copy of your file before running any code, as code tries to overwrite the contents of column A. (The procedure to run is PreprocessAndRemoveDuplicates.)
You may need to change the name of the sheet (in the code). I assumed "Sheet1".
Code assumes data is only in column A.
Option Explicit
Private Sub PreprocessAndRemoveDuplicates()
Dim targetSheet As Worksheet
Set targetSheet = ThisWorkbook.Worksheets("Sheet1") ' Change to whatever yours is called. You could use code name instead too.
Dim lastCell As Range
Set lastCell = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp)
Debug.Assert lastCell.Row > 1
Dim inputArray() As Variant
inputArray = targetSheet.Range("A1", lastCell) ' Assumes data starts from A1.
Dim uniqueValues As Scripting.Dictionary
Set uniqueValues = New Scripting.Dictionary
Dim rowIndex As Long
For rowIndex = LBound(inputArray, 1) To UBound(inputArray, 1)
Dim currentKey As String
currentKey = GetKeyFromValue(CStr(inputArray(rowIndex, 1)))
If Not uniqueValues.Exists(currentKey) Then ' Only first instance added.
uniqueValues.Add currentKey, inputArray(rowIndex, 1)
End If
Next rowIndex
WriteDictionaryItemsToSheet uniqueValues, targetSheet.Cells(1, lastCell.Column)
End Sub
Private Function GetKeyFromValue(ByVal someText As String, Optional charactersToExtract As Long = 4) As String
' If below logic is not correct/appropriate for your scenario, replace with whatever it should be.
' Presently this just gets the first N characters of the string, where N is 4 by default.
GetKeyFromValue = Left$(someText, charactersToExtract)
End Function
Private Sub WriteDictionaryItemsToSheet(ByVal someDictionary As Scripting.Dictionary, ByVal firstCell As Range)
Dim initialArray() As Variant
initialArray = someDictionary.Items()
Dim arrayToWriteToSheet() As Variant
arrayToWriteToSheet = StandardiseArray(initialArray)
With firstCell
.EntireColumn.ClearContents
.Resize(UBound(arrayToWriteToSheet, 1), UBound(arrayToWriteToSheet, 2)).Value = arrayToWriteToSheet
End With
End Sub
Private Function StandardiseArray(ByRef someArray() As Variant) As Variant()
' Application.Transpose might be limited to ~65k
Dim baseDifference As Long
baseDifference = 1 - LBound(someArray)
Dim rowCount As Long ' 1 based
rowCount = UBound(someArray) - LBound(someArray) + 1
Dim outputArray() As Variant
ReDim outputArray(1 To rowCount, 1 To 1)
Dim readIndex As Long
Dim writeIndex As Long
For readIndex = LBound(someArray) To UBound(someArray)
writeIndex = writeIndex + 1
outputArray(writeIndex, 1) = someArray(readIndex)
Next readIndex
StandardiseArray = outputArray
End Function
Processed 1 million values (A1:A1000000) in under 3 seconds on my machine, but performance on your machine may differ.
I want to compare the Sheet1 column A values with Sheet2 column B, if match then i want to put the Sheet1 Column A values in Sheet2 Column C.
and column D should be populated with 'True'
So i have written the below code:
Sub val()
Dim sheet1_last_rec_cnt As Long
Dim sheet2_last_rec_cnt As Long
Dim sheet1_col1_val As String
Dim cnt1 As Long
Dim cnt2 As Long
sheet1_last_rec_cnt = Sheet1.UsedRange.Rows.Count
sheet2_last_rec_cnt = Sheet2.UsedRange.Rows.Count
For cnt1 = 2 To sheet1_last_rec_cnt
sheet1_col1_val = Sheet1.Range("A" & cnt1).Value
For cnt2 = 2 To sheet2_last_rec_cnt
If sheet1_col1_val = Sheet2.Range("B" & cnt2).Value Then
Sheet2.Range("C" & cnt2).Value = sheet1_col1_val
Sheet2.Range("D" & cnt2).Value = "True"
Exit For
End If
Next
Next
End Sub
Problem is i have one millions of records in both the sheets.
if i use the above code then For loop is running (One million * One million) times. So excel is hanging like anything.
Can someone please help me to optimize the code?
For 1 million records I'm not sure Excel is the best place to be storing this data. If your code is designed to tidy up the data so that you can export it to a database then great ... if not, then, well, I fear rough seas lay ahead for you.
The code below will speed things up a touch as it only loops through each column once, and it populates a collection of unique values so that it only has to check against that instead of the whole column each time. If you sorted your rows then it could be made even quicker but I'll leave that one for you.
Public Sub RunMe()
Dim uniques As Collection
Dim sourceValues As Variant
Dim targetValues As Variant
Dim sourceItem As String
Dim targetItem As String
Dim sourceCount As Long
Dim targetCount As Long
Dim matches As Boolean
Dim output() As Variant
' Acquire the values to be compared.
With ThisWorkbook.Worksheets("Sheet1")
sourceValues = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp)).Value2
End With
With ThisWorkbook.Worksheets("Sheet2")
targetValues = .Range(.Cells(2, "B"), .Cells(.Rows.Count, "B").End(xlUp)).Value2
End With
'Resize the output array to size of target values array.
ReDim output(1 To UBound(targetValues, 1), 1 To 2)
sourceCount = 1
Set uniques = New Collection
'Iterate through the target values to find a match in the source values
For targetCount = 1 To UBound(targetValues, 1)
targetItem = CStr(targetValues(targetCount, 1))
matches = Contains(uniques, targetItem)
If Not matches Then
'Continue down the source sheet to check the values.
Do While sourceCount <= UBound(sourceValues, 1)
sourceItem = CStr(sourceValues(sourceCount, 1))
sourceCount = sourceCount + 1
'Add any new values to the collection.
If Not Contains(uniques, sourceItem) Then uniques.Add True, sourceItem
'Check for a match and leave the loop if we found one.
If sourceItem = targetItem Then
matches = True
Exit Do
End If
Loop
End If
'Update the output array if there's a match.
If matches Then
output(targetCount, 1) = targetItem
output(targetCount, 2) = True
End If
Next
'Write output array to the target sheet.
ThisWorkbook.Worksheets("Sheet2").Range("C2").Resize(UBound(targetValues, 1), 2).value = output
End Sub
Private Function Contains(col As Collection, key As String) As Boolean
'Function to test if the key already exists.
Contains = False
On Error Resume Next
Contains = col(key)
On Error GoTo 0
End Function
Am trying to parse an excel file using Excel VBA.
Here is the sample sata
I did some research and found you can assign ranges to array like
Arrayname = Range("A1:D200")
But am looking for some thing more dynamic, like add the below multiple ranges to a single array.
and my final array will be a single array/table with n is number of rows from all ranges and 4 columns.
Can any one please prvide me a example.
Thank you in adavance.
I think you are asking for more information about moving data between ranges and variables so that is the question I will attempt to answer.
Create a new workbook. Leave Sheet1 empty; set cell B3 of Sheet2 to "abc" and set cells C4 to F6 of Sheet3 to ="R"&ROW()&"C"&COLUMN()
Open the VB Editor, create a module and copy the follow code to it. Run macro Demo01().
Option Explicit
Sub Demo01()
Dim ColURV As Long
Dim InxWkSht As Long
Dim RowURV As Long
Dim UsedRangeValue As Variant
' For each worksheet in the workbook
For InxWkSht = 1 To Worksheets.Count
With Worksheets(InxWkSht)
Debug.Print .Name
If .UsedRange Is Nothing Then
Debug.Print " Empty sheet"
Else
Debug.Print " Row range: " & .UsedRange.Row & " to " & _
.UsedRange.Row + .UsedRange.Rows.Count - 1
Debug.Print " Col range: " & .UsedRange.Column & " to " & _
.UsedRange.Column + .UsedRange.Columns.Count - 1
End If
UsedRangeValue = .UsedRange.Value
If IsEmpty(UsedRangeValue) Then
Debug.Print " Empty sheet"
ElseIf VarType(UsedRangeValue) > vbArray Then
' More than one cell used
Debug.Print " Values:"
For RowURV = 1 To UBound(UsedRangeValue, 1)
Debug.Print " ";
For ColURV = 1 To UBound(UsedRangeValue, 2)
Debug.Print " " & UsedRangeValue(RowURV, ColURV);
Next
Debug.Print
Next
Else
' Must be single cell worksheet
Debug.Print " Value = " & UsedRangeValue
End If
End With
Next
End Sub
The following will appear in the Immediate Window:
Sheet1
Row range: 1 to 1
Col range: 1 to 1
Empty sheet
Sheet2
Row range: 3 to 3
Col range: 2 to 2
Value = abc
Sheet3
Row range: 4 to 6
Col range: 3 to 5
Values:
R4C3 R4C4 R4C5
R5C3 R5C4 R5C5
R6C3 R6C4 R6C5
If you work through the macro and study the output you will get an introduction to loading a range to a variant. The points I particularly want you to note are:
The variable to which the range is loaded is of type Variant. I have never tried loading a single range to a Variant array since the result may not be an array. Even if it works, I would find this confusing.
Sheet1 is empty but the used range tells you than cell A1 is used. However, the variant to which I have loaded the sheet is empty.
The variant only becomes an array if the range contains more than one cell. Note: the array will ALWAYS be two dimensional even if the range is a single row or a single column.
The lower bounds of the array are ALWAYS 1.
The column and row dimensions are not standard with the rows as dimension 1 and the columns as dimension 2.
If there is any doubt about the nature of the range being loaded, you must use IsEmpty and VarType to test its nature.
You may also like to look at: https://stackoverflow.com/a/16607070/973283. Skim the explanations of macros Demo01() and Demo02() which are not relevant to you but set the context. Macro Demo03() shows the advanced technique of loading multiple worksheets to a jagged array.
Now create a new worksheet and leave it with the default name of Sheet4.
Add the follow code to the module. Run macro Demo02().
Sub Demo02()
Dim ColOut As Long
Dim OutputValue() As String
Dim Rng As Range
Dim RowOut As Long
Dim Stg As String
ReDim OutputValue(5 To 10, 3 To 6)
For RowOut = LBound(OutputValue, 1) To UBound(OutputValue, 1)
For ColOut = LBound(OutputValue, 2) To UBound(OutputValue, 2)
OutputValue(RowOut, ColOut) = RowOut + ColOut
Next
Next
With Worksheets("Sheet4")
Set Rng = .Range("A1:D6")
End With
Rng.Value = OutputValue
With Worksheets("Sheet4")
Set Rng = .Range(.Cells(8, 2), .Cells(12, 4))
End With
Rng.Value = OutputValue
With Worksheets("Sheet4")
Stg = "C" & 14 & ":G" & 20
Set Rng = .Range(Stg)
End With
Rng.Value = OutputValue
End Sub
Although this macro writes an array to a worksheet, many of the points apply for the opposite direction. The points I particularly want you to note are:
For output, the array does not have to be Variant nor do the lower bounds have to be 1. I have made OutputValue a String array so the values output are strings. Change OutputValue to a Variant array and rerun the macro to see the effect.
I have used three different ways of creating the range to demonstrate some of your choices.
If you specify a range as I have, the worksheet is one of the properties of the range. That is why I can take Rng.Value = OutputValue outside the With ... End With and still have the data written to the correct worksheet.
When copying from a range to a variant, Excel sets the dimensions of the variant as appropriate. When copying from an array to a range, it is your responsibility to get the size of the range correct. With the second range, I lost data. With the third range, I gained N/As.
I hope the above gives you an idea of your options. If I understand your requirement correctly, you will have to:
Load the entire worksheet to Variant
Create a new Array of the appropriate size
Selectively copy data from the Variant to the Array.
Come back withh questions if anything is unclear.