I am having 2 issues that I've been trying to solve all day. First off whenever I try to watch any variable no matter what it says in the watches bar. I tried even just setting a variable to equal a number and watching it and it still gave me .
Second I am trying to put all of the values in column B that have a value into an array (TagName) and it is driving me up a wall. This is the point of the for loop. The out of context thing is not helping the case.
Just for reference "ist" was i as a string but then I added the B just to shorten the code.
Don't worry about the extra dims those are for code that is already working
Thank you for your help!
Sub GenTags()
Dim FolderPath As String
Dim OutputFileNum As Integer
Dim TagName(100) As String
Dim i As Long
Dim ist As String
Sheets("Parameters").Activate
For i = 1 To ActiveWorkbook.ActiveSheet.Columns("B").End(xlDown).Row
ist = "B" & CStr(i)
TagName(i) = ActiveWorkbook.Sheets("Parameters").Range(ist)
Next
End Sub
If you only want cells with values, you should probably have that as part of your loop. I think this should work. I also changed the array to be a variant in case you have a mix of string and numbers.
Sub GenTags()
Dim FolderPath As String
Dim OutputFileNum As Integer
Dim TagName(100) As Variant
Dim i As Long, c As Long
Dim ist As String
Sheets("Parameters").Activate
For i = 1 To ActiveWorkbook.ActiveSheet.Columns("B").End(xlDown).Row
If Not IsEmpty(Range("B" & i)) Then
TagName(c) = Range("B" & i).Value
c = c + 1
End If
Next
End Sub
This approach is a little more granular and takes care of empty cells in the column.
It's easy just yo customize the ">>>>" section
Sub GenTags()
Dim FolderPath As String
Dim OutputFileNum As Integer
Dim ist As String
' Define object variables
Dim sourceSheet As Worksheet
Dim paramSheet As Worksheet
Dim sourceRange As Range
Dim cellEval As Range
' Define other variables
Dim sourceSheetName As String
Dim paramSheetName As String
Dim sourceColumn As String
Dim tagName() As Variant
Dim counter As Long ' before i
Dim nonBlankCounter As Long
Dim totalCells As Long
' >>> Customize to fit your needs
sourceSheetName = "Sheet1"
paramSheetName = "Parameters"
sourceColumn = "B"
' Initialize objects - Change sheets names
Set sourceSheet = ThisWorkbook.Worksheets(sourceSheetName)
Set paramSheet = ThisWorkbook.Worksheets(paramSheetName)
Set sourceRange = Application.Union(sourceSheet.Columns(sourceColumn).SpecialCells(xlCellTypeConstants), sourceSheet.Columns(sourceColumn).SpecialCells(xlCellTypeFormulas))
' Get how many items in column b are
totalCells = sourceRange.Cells.Count
' Redimension the array to include all the items
ReDim tagName(totalCells)
' Initilize the counter (for documentation sake)
counter = 0
For Each cellEval In sourceRange
' Add non empty values
If Trim(cellEval.Value) <> vbNullString Then
' Store it in the array
tagName(counter) = cellEval.Value
counter = counter + 1
End If
Next cellEval
' Redim to leave only used items
ReDim Preserve tagName(counter - 1)
End Sub
Let me know if it helps!
Thank you for your responses. Unfortunatley I had to put this project on the back burner until yesterday but I did try both answers and they didn't work. I decided to go a different direction with the entire code and got it working. Thank you for your help and sorry for the late response.
Related
I have two files and its important the file type remains unchanged.
Firstly, Stack.xlsm
With only one row of data.
The following function takes the two datapoints and saves them into an array that is returned. So, the cells A5=StudentData(1), B5=StudentData(2)
Public Function StudentData(Index As Integer)
Dim StudentID As Double
Dim StudentScore As Double
Dim IntA(1 To 2) As Double
StudentID = ActiveSheet.Cells(2, 1)
StudentScore = ActiveSheet.Cells(2, 2)
IntA(1) = StudentID
IntA(2) = StudentScore
StudentData = IntA(Index)
End Function
Secondly, Test.xlsx.
I am trying to maintain this file as a .xlsx but somehow write data to it (This should be the result after running the desired sub):
I want to overwrite the cells in this sheet such that A1= "ID:" & StudentData(1), B1="Score:" &StudentData(2), ie calling the function defined in Stack.xlsm
I assume this will be achieved in Stack.xlsm, with something like:
Public Sub DataTransfer()
Workbooks("Test.xlsx").Worksheets("Sheet1").cell(A1) = "ID:" & StudentData(1)
Workbooks("Test.xlsx").Worksheets("Sheet1").cell(B1) = "Score:" & StudentData(2)
End Sub
The syntax is wrong but I hope it shows my intentions.
Copy Values
When you do Dim Student(1 To 2) As Double (or in your function Dim IntA(1 To 2) As Double) you have already determined that you will be accessing the values by index i.e. Student(1) and Student(2). There is no need (possibility) to use an index argument for that.
If you're going to hard-code the row index, then your function signature will be
Function StudentData(ByVal ws As Worksheet) As Double()
with one argument.
If you're also going to hard-code the worksheet, then your function signature will be
Function StudentData() As Double()
without arguments.
An Idea
Function StudentData( _
ByVal ws As Worksheet, _
ByVal RowIndex As Long) _
As Double()
' 'StudentID' and 'StudentScore' are beautiful variable names,
' but they don't serve much of a purpose.
Dim StudentID As Double: StudentID = ws.Cells(RowIndex, "A").Value
Dim StudentScore As Double: StudentScore = ws.Cells(RowIndex, "B").Value
Dim Student(1 To 2) As Double
Student(1) = StudentID
Student(2) = StudentScore
StudentData = Student
End Function
Sub DataTransfer()
Dim sws As Worksheet: Set sws = ThisWorkbook.Worksheets("Sheet1")
Dim sRow As Long: sRow = 5
Dim Student() As Double: Student = StudentData(sws, sRow)
Dim dws As Worksheet: Set dws = Workbooks("Test.xlsx").Worksheets("Sheet1")
Dim dRow As Long: dRow = 1
dws.Cells(dRow, "A").Value = "ID:" & Student(1)
dws.Cells(dRow, "B").Value = "Score:" & Student(2)
End Sub
Hopefully, you're just practicing to better understand ranges, arrays, functions, etc. because all these complications boil down to the following:
Sub DataTransferSolo()
Dim sws As Worksheet: Set sws = ThisWorkbook.Worksheets("Sheet1")
Dim dws As Worksheet: Set dws = Workbooks("Test.xlsx").Worksheets("Sheet1")
dws.Range("A1").Value = "ID:" & sws.Range("A5").Value
dws.Range("B1").Value = "Score:" & sws.Range("B5").Value
End Sub
Finally
After finally understanding what you were doing, the problem with it is that you're retrieving both values (writing them from the worksheet to an array) to get only one value as the result of the function which is rather inefficient because you have to run it twice to get both values.
Passing an array as the result, as shown in the above code, reads the data once (most importantly, accesses the worksheet once) and is the way to go. You can efficiently (quickly) access any value any number of times from the passed array in the calling procedure.
As a learning exercise & possible use in future code I have created my first Excel VBA function to return the activecell row number in any Excel Table (as opposed to the sheet itself) . Essentially it simply finds the active row in the sheet, then finds the row number of the table header which is then subtracted from the cell row number to return the row number of the table which can then be used in subsequent code. However, while it works, it dosen't look the most efficient Can anyone improve it?
Sub TableRow()
Dim LORow As Integer
Dim TbleCell As Range
Set TbleCell = Activecell
Call FuncTableRow(TbleCell, LORow)
MsgBox LORow
End Sub
Public Function FuncTableRow(ByRef TbleCell As Range, LORow As Integer) As Range
Dim LOName As String
Dim LOHeaderRow, Row As Integer
LOName = Activecell.ListObject.Name
Row = Activecell.Row
LOHeaderRow = ActiveSheet.ListObjects(LOName).HeaderRowRange.Row
LORow = Row - LOHeaderRow
Debug.Print (LORow)
End Function
This question will probably get closed for not being specific enough but the most obvious item (to me) is your usage of a custom function. Your function is not actually returning anything, it's only running a debug print. To have your function actually return the row number, you would set it as a type Long (not integer) and include the function name = to the number.
I didn't actually test your function but assuming LORow is dubug printing the proper answer then it should work like this:
Public Function FuncTableRow(ByRef TbleCell As Range, LORow As Integer) As Long
Dim LOName As String
Dim LOHeaderRow, Row As Integer
LOName = Activecell.ListObject.Name
Row = Activecell.Row
LOHeaderRow = ActiveSheet.ListObjects(LOName).HeaderRowRange.Row
LORow = Row - LOHeaderRow
Debug.Print (LORow)
FuncTableRow = LORow
End Function
You also don't Call a function, you can just insert it as itself in a subroutine.
You are using LORow as an input variable but then changing it. That's typically a bad practice.
You should not be using ActiveSheet grab the worksheet from TbleCell.Worksheet
You would almost never use activecell as part of a Custom Formula.
Dim LOHeaderRow, Row As Integer should actually be Dim LOHeaderRow as Long, Row As Long. As you currently have it LOHeaderRow is undefined/Variant.
There's probably more. I would restart your process with a simpler task of returning the last used cell in a worksheet. There's a dozen ways to do this and lots of help examples.
Take a look at this TheSpreadsheetGuru.
Here are some variables that might help you.
Sub TableVariables()
Dim ol As ListObject: Set ol = ActiveSheet.ListObjects(1)
Dim olRng As Range: Set olRng = ol.Range ' table absolute address
Dim olRngStr As String: olRngStr = ol.Range.Address(False, False) ' table address without absolute reference '$'
Dim olRow As Integer: olRow = ol.Range.Row ' first row position
Dim olCol As Integer: olCol = ol.Range.Column ' first column position
Dim olRows As Long: olRows = ol.Range.Rows.Count ' table rows including header
Dim olCols As Long: olCols = ol.ListColumns.Count ' table columns
Dim olListRows As Long: olListRows = ol.ListRows.Count ' table rows without header
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'm really losing my mind with this so would appreciate anyone taking the time to help!
I suspect my problems stem from incorrect variable declaration but I haven't been able to work it out.
So why does this test procedure work:
Sub testmatch3()
Dim arr() As Variant
Dim num As Long
Dim searchVal As Variant
Dim i As Long
ReDim arr(1 To 10)
For i = 1 To 10
arr(i) = i
Next i
searchVal = 4
Debug.Print getMatch(searchVal, arr)
End Sub
Function getMatch(valueToMatch As Variant, matchArr As Variant) As Long
getMatch = Application.WorksheetFunction.Match(valueToMatch, matchArr, 0)
End Function
But the following gives me a mismatch error (Type 13):
Sub NewProcedure()
Dim ENVarr As Variant
Dim StageRange As Range
Dim cell As Range
Dim LastRow As Long
Dim i As Long
Dim ConnSheet As Worksheet
Dim tempstring As Variant
Dim arr() As Variant
Set ConnSheet = ThisWorkbook.Sheets("L1 forces")
' Find the last used row in the sheet and define the required ranges
LastRow = ConnSheet.Range("A11").End(xlDown).row
Set StageRange = ConnSheet.Range("H11:H" & LastRow)
' I have a big table of data in the "ENV sheet" which I transfer into a large 2D array
ENVarr = ThisWorkbook.Worksheets("ENV").Range("A6").CurrentRegion
' From the ENVarray, make its second column into a new 1D array
' This new array has an upper bound dimension equal to the number of rows in ENVarr
ReDim arr(LBound(ENVarr, 1) To UBound(ENVarr, 1))
For i = LBound(arr) To UBound(arr)
arr(i) = ENVarr(i, 2)
Next i
tempstring = "1140"
Debug.Print getMatch(tempstring, arr)
End Sub
Function getMatch(valueToMatch As Variant, matchArr As Variant) As Long
getMatch = Application.WorksheetFunction.Match(valueToMatch, matchArr, 0)
End Function
Just to note the value "1140" DEFINITELY exists in arr!
Thanks
I suppose in your sheet is the number 1140 and you try to match the string "1140". Did you try to write
tempstring = 1140
without quotes?
Alternatively: make sure that there is really a string in your excel sheet: ="1140" and it is not only formatted as string. The return value of =TYPE(cell) ('cell' is containing your 1140) has to be 2.
I'm in a module function, and I have a value that needs to get updated across multiple worksheets. I would like to take a data driven approach to this, since it may change a bit in the future.
In essence, I want to create an array of strings, each entry is an absolute reference to a cell, something like so:
Array("'Sheet1'!$A$1","'Sheet2'!$C$5")
I'd like to be able to do something like so
for each item in arr
Range(item).value = some_value
next item
The issue is that I'm in a module, The Range property is only available on a worksheet, and if I try to reference worksheet B from worksheet A via the Range property, it gives me an error.
How would you go about doing this?
Create an array of range objects like so:
arr = Array(WorkSheets("Sheet1").Range("A1"), WorkSheets("Sheet2").Range("C5"))
Dim rng as Range
For i = LBound(arr) To UBound(arr)
arr(i).Value = some_value
Next i
You could also use the Collection class
Dim coll As New Collection
Dim rng As Range
coll.Add WorkSheets("Sheet1").Range("A1")
coll.Add WorkSheets("Sheet2").Range("C5")
For Each rng In coll
rng.Value = some_value
Next rng
Given an array of string addresses, you can process it like
Sub Demo()
Dim arr As Variant
Dim sh As String, addr As String
Dim item As Variant
arr = Array("'Sheet 1'!$A$1", "'Sheet2'!$C$5")
For Each item In arr
sh = Replace(Left(item, InStr(item, "!") - 1), "'", "")
addr = Mid(item, InStr(item, "!") + 1)
Worksheets(sh).Range(addr) = some_value
Next
End Sub
If you can switch to an array (or collection) of Range then justnS' answer is better. But if you need to stick with an array of strings, this will do it.
You ask about multiple worksheets but say your program may be extended later. If it possible that you will need to update multiple workbooks, the following may be helpful.
I have set the array elements to workbook name, worksheet name, cell address and value. I have assumed the destination workbooks are open although it would not be difficult for the macro to open them if necessary. I test the workbook and worksheet names but not the cell address.
Sub Test1()
'
Dim Dest() As Variant
Dim DestPart() As String
Dim Found As Boolean
Dim InxBook As Integer
Dim InxDest As Integer
Dim InxSheet As Integer
Dest = Array("Test1.xls|Sheet3|B1|abc", "Test2.xls|Sheet2|F5|def", _
"Test3.xls|Sheet1|D3|ghi")
' Each element of Dest contains: workbook name, sheet name, cell address,
' and value separated by pipes.
' This code assumes the destination workbooks are already open.
For InxDest = LBound(Dest) To UBound(Dest)
DestPart = Split(Dest(InxDest), "|")
Found = False
For InxBook = 1 To Workbooks.Count
If DestPart(0) = Workbooks(InxBook).Name Then
Found = True
Exit For
End If
Next
If Found Then
With Workbooks(InxBook)
Found = False
For InxSheet = 1 To .Sheets.Count
If DestPart(1) = .Sheets(InxSheet).Name Then
Found = True
Exit For
End If
Next
If Found Then
.Sheets(InxSheet).Range(DestPart(2)).Value = DestPart(3)
End If
End With
End If
Next
End Sub