Is there any possible way to take a list of items or names, such as:
Apples
Oranges
Grapes
Watermelons
And have Excel double that information and sequentially number it, like this:
Apples1
Apples2
Oranges1
Oranges2
Grapes1
Grapes2
Watermelons1
Watermelons2
I know a little bit of VBA but I can't wrap my head around how I would even start this.
You can specify where you want to read, and where you want to start write and how many times you want to repeat!
Just change the code:
Sub DoRepeat()
Dim repeatTimes As Integer
Dim rng As Range, cell As Range
repeatTimes = 2
Set cellsToRead = Range("A1:A3")
Set cellStartToWrite = Range("B1")
For Each cell In cellsToRead
For i = 1 To repeatTimes
cellStartToWrite.Value = cell.Value + CStr(i)
Set cellStartToWrite = Cells(cellStartToWrite.Row + 1, cellStartToWrite.Column)
Next
Next cell
End Sub
As it seems it is required to have a more dynamic approach, try this out. The DoubleNames function will return the names duplicated N number of times specified in the DuplicateCount parameter. It will return a Collection, which you can easily dump to a range if need be.
Public Function DoubleNames(ByVal DataRange As Excel.Range, DuplicateCount As Long) As Collection
Set DoubleNames = New Collection
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim i As Long
Dim DataItem As Excel.Range
Set DataRange = DataRange.SpecialCells(xlCellTypeConstants)
For Each DataItem In DataRange
For i = 1 To DuplicateCount
If Not dict.Exists(DataItem.Value) Then
DoubleNames.Add (DataItem.Value & "1")
dict.Add DataItem.Value, 1
Else
dict(DataItem.Value) = dict(DataItem.Value) + 1
DoubleNames.Add (DataItem.Value & dict(DataItem.Value))
End If
Next
Next
End Function
Sub ExampleUsage()
Dim item As Variant
Dim rng As Range: Set rng = ThisWorkbook.Sheets("Sheet1").Range("A1:A5")
For Each item In DoubleNames(rng, 5)
Debug.Print item
Next
End Sub
I would start by writing a general function that outputs the names (passed as a variant array) a given number of times:
Public Sub OutputNames(ByVal TimesToOutput As Integer, ByRef names() As Variant)
Dim nameIndex As Integer, outputIndex As Integer
For nameIndex = LBound(names) To UBound(names)
For outputIndex = 1 To TimesToOutput
Debug.Print names(nameIndex) & outputIndex
Next outputIndex
Next nameIndex
End Sub
Here you can see the sub that tests this:
Public Sub testOutputNames()
Dim names() As Variant
names = Array("Apples", "Oranges", "Grapes", "Watermelons")
OutputNames 2, names
End Sub
which gives you this output:
Apples1
Apples2
Oranges1
Oranges2
Grapes1
Grapes2
Watermelons1
Watermelons2
Related
I have a list of cells that I want to randomly select from by clicking a button with no repeats, and display the value in another cell. After a certain point I want to be able to "reset" so that all of the cells are eligible to be chosen, weather that's after 2 random selections or after 50.
I already have a macro to randomly select a cell and display that cell's value somewhere else (see below).
Sub MGen()
Dim ws As Worksheet
Dim stRow As Long, endRow As Long, dataCol As Long
Dim dispRow As Long, dispCol As Long
Set ws = Sheets("MHome")
stRow = 2
dataCol = 1
dispRow = 3
dispCol = 4
With ws
endRow = .Cells(.Rows.Count, dataCol).End(xlUp).Row
.Cells(dispRow, dispCol).Value = _
.Cells(Application.RandBetween(stRow, endRow), dataCol).Value
End With
End Sub
With altering this macro for no repeats, do I need another macro for the "reset"?
I propose to use a "virtual" list of randomly sorted values (m_arrRandomSortOrder) that is retrieved by the function getListRandomSortOrder
Calling the getValueFromRandomList-function returns the next value from the array and increases the module level variable m_NextIndex.
reset does what it is called: returns a new randomly sorted array and resets m_NextIndex to 0
I am assuming that there are to workbook names:
Values: the range you take the values from
Target: the cell where you want to write the random value
writeNewValue or reset have to be called from "outside"
Option Explicit
Private Const nameTargetCell As String = "Target"
Private Const nameValueRange As String = "Values"
Private m_arrRandomSort As Variant
Private m_NextIndex As Long
Public Sub writeNewValue()
Dim rgTarget As Range: Set rgTarget = ThisWorkbook.Names(nameTargetCell).RefersToRange
rgTarget.Value = getValueFromRandomList
End Sub
Public Sub reset()
Dim rgValues As Range
Set rgValues = ThisWorkbook.Names(nameValueRange).RefersToRange
m_arrRandomSort = getListRandomSortOrder(rgValues)
m_NextIndex = 0
End Sub
Private Function getValueFromRandomList() As Variant
'this function returns the next value from the randomly sorted array
'when all values have been selected (m_lastindex +1 > ubound of m_arrRandomSort
'user is asked to reset or to cancel
If Not IsArray(m_arrRandomSort) Then
reset
ElseIf m_NextIndex > UBound(m_arrRandomSort) Then
If vbOK = MsgBox("All values have been selected." & vbCrLf & _
"Reset the list?", vbOKCancel + vbExclamation) Then
reset
Else
Exit Function
End If
End If
getValueFromRandomList = m_arrRandomSort(m_NextIndex)
m_NextIndex = m_NextIndex + 1
End Function
Private Function getListRandomSortOrder(rg As Range) As Variant
'this function returns a one-dimensional array where all values of rg are randomly sorted
Dim arr1 As Variant, arr2 As Variant
With Application.WorksheetFunction
arr1 = .SortBy(rg, .RandArray(rg.Rows.Count), 1)
End With
Dim i As Long
ReDim arr2(0 To UBound(arr1, 1) - 1)
For i = 0 To UBound(arr2)
arr2(i) = arr1(i + 1, 1)
Next
getListRandomSortOrder = arr2
End Function
I'm a newbie in the programming world and I'm currently facing a challenge on VBA.
I've built a monthly calendar spreadsheet, and below every day number there is an empty space to be filled depending on some conditions.
I want to fill these spaces with a list of names, depending if the person has the value of Active or not. Another imposed condition is if the date of the calendar is a holliday the cell will remain an empty space, therefore I did a list of hollidays to test this condition.
Here goes the code i made so far:
Sub teste()
line_fill = 5
line_names = 3
column_names = 17
column_active = 18
For i = 6 To 10
Dim values As Worksheets("Planilha1").Cells(5, i))
Dim test As Worksheets("Planilha1").Cells(line_fill - 1, i)
Dim names As Worksheets("Planilha1").Cells(line_names, column_active)
Dim active As Worksheets("Planilha1").Cells(line_names, column_names)
If IsEmpty(test) And test.value <> WorksheetFunction.VLookup(test.value, Sheet1.Range("M4:M100"), 1, False) Then
If names.value = "Ativo" Then
values = active
line_names = line_names + 1
i = i + 1
Next i
End Sub
Image of the spreadsheet
Link to the spreadsheet I'm using
Please try to step through the code with F8 so you understand what I did and try to adjust it to fit your needs.
This is the setup I used to code it:
And this is the code:
Option Explicit
Public Sub CopyValuesInCalendar()
Dim targetSheet As Worksheet
Dim calendarRange As Range
Dim holidaysRange As Range
Dim teamRange As Range
Dim evalDayCell As Range
Dim teamFilteredList As Variant
Dim holidayLastRow As Long
Dim teamLastRow As Long
Dim counter As Long
Set targetSheet = ThisWorkbook.Worksheets("Planilha1")
targetSheet.AutoFilterMode = False
Set calendarRange = targetSheet.Range("D4:J13")
holidayLastRow = targetSheet.Cells(targetSheet.Rows.Count, 12).End(xlUp).Row
teamLastRow = targetSheet.Cells(targetSheet.Rows.Count, 16).End(xlUp).Row
Set holidaysRange = targetSheet.Range("L4:N" & holidayLastRow)
Set teamRange = targetSheet.Range("P3:Q" & teamLastRow)
teamFilteredList = GetActiveTeamMembers(teamRange)
For Each evalDayCell In calendarRange.Cells
If IsNumeric(evalDayCell.Value) And evalDayCell.Value <> vbNullString Then
If Not IsHoliday(evalDayCell.Value, holidaysRange) Then
If counter > UBound(teamFilteredList) Then
counter = 1
Else
counter = counter + 1
End If
evalDayCell.Offset(1, 0).Value = GetTeamMemberName(counter, teamFilteredList)
End If
End If
Next evalDayCell
End Sub
Private Function IsHoliday(ByVal dayNum As Long, ByVal holidayRange As Range) As Boolean
Dim evalCell As Range
For Each evalCell In holidayRange.Columns(1).Cells
If evalCell.Value = dayNum Then
IsHoliday = True
End If
Next evalCell
End Function
Private Function GetActiveTeamMembers(ByVal teamRange As Range) As Variant
Dim evalCell As Range
Dim counter As Long
Dim tempList() As Variant
For Each evalCell In teamRange.Columns(1).Cells
If evalCell.Offset(0, 1).Value = "Ativo" Then
ReDim Preserve tempList(counter)
tempList(counter) = evalCell.Value
counter = counter + 1
End If
Next evalCell
GetActiveTeamMembers = tempList
End Function
Private Function GetTeamMemberName(ByVal counter As Long, ByVal teamFilteredList As Variant) As String
GetTeamMemberName = teamFilteredList(counter - 1)
End Function
Let me know if it helps.
I have an array of a user-defined type and want to get data from a worksheet into this array. I have a solution but it seems inelegant. Is there a better or easier way to do this?
Type Donation
NBID As Integer
Amount As Single
DonationDate As Date
TrackingCode As String
End Type
Public dons() as Donation
Sub init()
Dim i As Integer
Dim tmpDons() As Variant
Dim donRows as Integer
tmpDons = Sheets("Appeal Dons").UsedRange.Value2
donRows = UBound(tmpDons)
ReDim dons(donRows - 2)
For i = 2 To donRows
dons(i - 2).NBID = tmpDons(i, 1)
dons(i - 2).Amount = tmpDons(i, 2)
dons(i - 2).TrackingCode = tmpDons(i, 3)
dons(i - 2).DonationDate = tmpDons(i, 4)
Next
End Sub
Try:
Option Explicit
Sub test()
Dim arr As Variant
Dim i As Long
With ThisWorkbook.Worksheets("Sheet1")
'Import to array the used range
arr = .UsedRange
'Loop from L to U arr bound
For i = LBound(arr) To UBound(arr)
'Code
Next i
End With
End Sub
I am trying to get the values of the visible cells of a range into an array.
My code makes the array carry the values until the first non visible cell then stops.
Public Function ListeMaschinen() As Variant
Dim Auswahl As Range
With Sheets("qry_TechnischesDatenblatt")
Set Auswahl = .Range(.Range("A2:B2"), .Range("A2:B2").End(xlDown)).SpecialCells(xlCellTypeVisible)
End With
ListeMaschinen = Auswahl
End Function
If I select the range it shows all the cells I want marked.
Auswahl.Select
Here I have added the range cells to an array.
Sub examp()
Dim rng As Range, cll As Range, i As Integer, a(100) As Variant
Set rng = Range(Range("A2:B2"), Range("A2:B2").End(xlDown)).SpecialCells(xlCellTypeVisible)
i = 0
For Each cll In rng
a(i) = cll.Value
i = i + 1
Next
End Sub
In your code, you are setting a Variant variable equal to a Range object without using the Set statement.
The following works with the little testing I did. Of course, if you declare the function type and other variables as Range type, it also works.
Option Explicit
Sub test()
Dim myVar As Variant
Set myVar = myList()
Debug.Print myVar.Address
End Sub
Public Function myList() As Variant
Dim myRng As Range
With Sheets("Sheet1")
Set myRng = .Range(.Range("A1:B1"), .Range("A1:B1").End(xlDown)).SpecialCells(xlCellTypeVisible)
End With
Debug.Print myRng.Address
Set myList = myRng
End Function
I think your issue is related to
.SpecialCells(xlCellTypeVisible)
When I do this:
Public Function ListeMaschinen() As Variant
Dim Auswahl As Range
With Sheets("qry_TechnischesDatenblatt")
Set Auswahl = .Range(.Range("A2:B2"), .Range("A2:B2").End(xlDown)).SpecialCells(xlCellTypeVisible)
End With
MsgBox Auswahl.Address
Set ListeMaschinen = Auswahl
'Auswahl.Select
End Function
I get an Address composed of 2 parts: the visible parts!
But when I remove the SpecialCells
Public Function ListeMaschinen() As Variant
Dim Auswahl As Range
With Sheets("qry_TechnischesDatenblatt")
Set Auswahl = .Range(.Range("A2:B2"), .Range("A2:B2").End(xlDown))
End With
MsgBox Auswahl.Address
Set ListeMaschinen = Auswahl
End Function
I get one single part, which Is what I get when using Select too.
I tested!
Sub test()
Dim myVar As Variant
Dim i As Integer
i = 0
Set myVar = ListeMaschinen()
For Each C In myVar
i = i + 1
MsgBox C.Value & C.Address & "-" & i
Next
End Sub
Further to my comments earlier, here is a method that will work subject to some limitations:
You can't have more than 65536 rows of data; and
You can't have really long text (911 chars+), or blank visible cells; and
The data should not contain the string "|~|"
If those conditions are met, you can use something like this:
Dim v
Dim sFormula As String
With Selection
sFormula = "IF(SUBTOTAL(103,OFFSET(" & .Cells(1).Address(0, 0) & ",row(" & .Address(0, 0) & ")-min(row(" & .Address(0, 0) & ")),1))," & .Address(0, 0) & ",""|~|"")"
End With
Debug.Print sFormula
v = Filter(Application.Transpose(Evaluate(sFormula)), "|~|", False)
You can adapt this to work round the third limitation by changing the alternate text in the formula string.
Hello :) I was trying to find a way to loop through visible rows in a table without going through all the rows and checking if they are visible as this was consuming too much time on a large table. Below is the solution I was able to come up with. It is a function that returns an array of the absolute row numbers of visible rows in a given Range.
Function GetVisibleRows(LookupRange As Range) As Integer()
Dim VisibleRange As Range, Index As Integer, Area As Range
Static VisibleRows() As Integer
Set VisibleRange = LookupRange.SpecialCells(xlCellTypeVisible)
ReDim VisibleRows(0)
Index = 0
For Each Area In VisibleRange.Areas
If Index = 0 Then
VisibleRows(Index) = Area.Row
ReDim Preserve VisibleRows(Index + 1)
End If
Index = UBound(VisibleRows())
If VisibleRows(Index - 1) <> Area.Row Then
VisibleRows(Index) = Area.Row
ReDim Preserve VisibleRows(Index + 1)
End If
Next
' Remove last empty item
ReDim Preserve VisibleRows(UBound(VisibleRows()) - 1)
GetVisibleRows = VisibleRows
End Function
If you would like to use this function in a lookup scenario, you need to convert the absolute row numbers returned by the function to relative row numbers of the table. Following worked for me.
RowIndex = ReturnedRowIndex - LookupRange.Rows(1).Row + 1
Good luck!
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.