i need to set a variable name that changes within a loop. Please look below:
The result i need is:
Vari1 = 1
Vari2 = 2
Vari3 = 3
What i tried:
for i = 1 to 3
Vari(i) = i ' (Vari & i) also doesnt work
next i
Any thoughts?
Thanks
First return the dynamic i from your code somehow (simplified below) then resize your array:
Sub Test()
Dim Vari() As Long
Dim i As Long, x As Long
'Get value of i somehow
i = 3
ReDim Vari(1 To i)
For x = 1 To i
Vari(x) = x
Next x
End Sub
Or populate a Variant data type array directly through Evaluate:
Sub Test()
Dim Vari() As Variant
Dim i As Long
'Get value of i somehow
i = 3
Vari = Evaluate("TRANSPOSE(ROW(1:" & i & "))")
End Sub
Related
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 want to count how many times appear the parameters CA, CU and CH, in an excel that looks like this:
I have tried to use the following code, but as the cells don't contain only the parameter I am searching for, it doesn't work:
Sub ContarOV()
Dim cont As Variant
Dim sumaCA As Variant
Dim sumaCU As Variant
Dim sumaCH As Variant
sumaCA = 0
sumaCU = 0
sumaCH = 0
For cont = 3 To 12
If Cells(cont, 2) = ("CA") Then
sumaCA = sumaCA + 1
End If
If Cells(cont, 2) = ("CU") Then
sumaCU = sumaCU + 1
End If
If Cells(cont, 2) = ("CH") Then
sumaCH = sumaCH + 1
End If
Next cont
End Sub
As per #BigBen, I would try to avoid any iteration. What about one of the following options (assuming your data sits from A2:A?):
Sub Test()
Dim lr As Long, x As Long
Dim arr As Variant
Dim rng As Range
With Sheet1 'Change according to your sheets CodeName
'Get last used row
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
'Get data into memory for method 1
arr = Application.Transpose(.Range("A2:A" & lr).Value)
'Create range object for method 2
Set rng = .Range("A2:A" & lr)
'Method 1: Count values with FILTER
Debug.Print UBound(Filter(arr, "CA")) + 1
Debug.Print UBound(Filter(arr, "CU")) + 1
Debug.Print UBound(Filter(arr, "CH")) + 1
'Method 2: Count values with COUNTIF
Debug.Print WorksheetFunction.CountIf(rng, "CA*")
Debug.Print WorksheetFunction.CountIf(rng, "CU*")
Debug.Print WorksheetFunction.CountIf(rng, "CH*")
End With
End Sub
Btw, I would give sumaCA and your other variables a meaningfull data type, Long in this case.
You can use InStr() to return the position of the desired characters in the string. This would look something like If Not InStr(1, Cells(cont,2).Text, "CH") = 0 Then, but looping through strings is generally a slow process. Unless you have a specific need for looping, I like BigBen's answer a lot better than I like looping with InStr().
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
I have three files - Excel_In1.xls, Excel_In2.xls and Excel_Out.xls.
There are two column say column L,M in Excel_In1.xls which contains keywords (of form product123 and companyABC) I need to search for these pairs of keywords in two columns (say A,B) in Excel_In2.xls. There are multiple rows in Excel_In2.xls with the keywords in that columns A,B.
I need to copy particular columns (say for instance three columns B,X,Z) in all the rows which contain the keyword product123 in the column A and companyABC in column B in Excel_In2.xls to the file Excel_Out.xls.
What is the best and simple way to accomplish this in VB script macros in Excel_Out.xls?
I also want to open the files Excel_In1.xls and Excel_In2.xls in macro in Excel_Out.xls.
my assumptions:
Excel_In1.xls == catalog.xlsx (table has unique key pair columnA & columnB in each row)
Excel_In2.xls == factdata.xlsx (table has multiple duplicate key pairs; and contains data in fixed columns to be copied)
Excel_Out.xls == book Out.xlsm
Option Explicit
Private Type TState
catalog As Object
selectedData As Object
End Type
Private this As TState
Public Sub ExampleSubMain()
Init
PickData
ExecuteCopying
End Sub
Private Sub Init()
InitCatalogDictionary
Set this.selectedData = CreateObject("Scripting.Dictionary")
End Sub
Private Sub InitCatalogDictionary()
MakeTheBookOpened "D:\vba\somefolder\", "catalog.xlsx"
Dim wb As Workbook
Set wb = Workbooks("catalog.xlsx")
Dim dataRange As Range
Set dataRange = wb.Worksheets("catalogSheet").Range("a2:b10") 'for example "a2:b10"
Set this.catalog = MakeDict(dataRange)
End Sub
Private Function MakeDict(ByVal dataRange As Range) As Object
Dim result As Object
Set result = CreateObject("Scripting.Dictionary")
Dim row As Range
For Each row In dataRange.Rows
'asumes column A,B are true keys and their pairs are unique, value = empty string
result.Add Join(Array(row.Cells(1), row.Cells(2))), ""
Next row
Set MakeDict = result
End Function
Private Sub MakeTheBookOpened(ByVal pathWithSeparator As String, _
ByVal wbName As String)
If TheBookIsOpenedAlready(wbName) Then Exit Sub
Workbooks.Open Filename:=pathWithSeparator & wbName, ReadOnly:=True
End Sub
Private Function TheBookIsOpenedAlready(ByVal Name As String) As Boolean
Dim wb As Workbook
For Each wb In Workbooks
If wb.Name = Name Then TheBookIsOpenedAlready = True: Exit Function
Next wb
End Function
Private Sub PickData()
MakeTheBookOpened "D:\vba\somefolder\", "factdata.xlsx"
Dim wb As Workbook
Set wb = Workbooks("factdata.xlsx")
Dim dataRange As Range
Set dataRange = wb.Worksheets("factSheet").Range("a2:k10") 'for example "a2:k10"
Dim row As Range
For Each row In dataRange.Rows
Dim key As String
key = Join(Array(row.Cells(4), row.Cells(6))) 'asumes product123, companyABC columns are there
If this.catalog.Exists(key) Then this.selectedData.Add row, ""
Next row
End Sub
Private Sub ExecuteCopying()
If this.selectedData.Count = 0 Then Exit Sub
Dim rowsNum As Long
rowsNum = this.selectedData.Count
Dim columnsNum As Long
columnsNum = 3 'for example 3
Dim resultArr As Variant
ReDim resultArr(1 To rowsNum, 1 To columnsNum)
Dim pos As Long
pos = 1
Dim item As Variant
For Each item In this.selectedData
Dim row As Range
Set row = item
resultArr(pos, 1) = row.Cells(2) 'B
resultArr(pos, 2) = row.Cells(7) 'G
resultArr(pos, 3) = row.Cells(10) 'J
pos = pos + 1
Next item
'book Out.xlsm
ThisWorkbook.Worksheets(1).Range("a1").Resize(rowsNum, columnsNum) = resultArr
End Sub
Given two basic input files roughly matching your description:
and
And assuming the macro would reside in the out file, we could construct a multi-function macro to accomplish this with a few steps.
The first part of the macro knows filenames and parameters. You used column L in the first input file, but let's make that configurable. The same with most of the other parameters, like the first line to start on so our input files can have headers.
Second, we need to open the first input file and read the keywords. There's several ways to do this, but a very simple way to do it is to do a plan CSV line, so that from the first file, you can extract your "keywords" (your term): product123,product456. This can then be iterated over with a For Each loop through the second file.
In the second file, a very simple construct would be to loop over all entries. Depending on your needs, you may need to iterate through the second file only once if it is prohibitively large. Both of these function assume the first blank line terminates the input. If the row in the 2nd input file matches your target, you will perform your copy.
Finally, the copy also takes a CSV line for which columns to keep (keeping it configurable). Each column, as well as the first keyword, will be copied to the target worksheet, starting at row 1 with a configurable column start.
The final output in the output sheet looks something like this:
The output starts in the second column because that was what was specified in the configuration.
There may be more elegant approaches, but this is a straight-forward approach to it.
Const EXCEL_1 As String = "\Excel1.xls"
Const EXCEL_1_KW_COL As String = "A"
Const EXCEL_2 As String = "\Excel2.xls"
Const EXCEL_2_KW_COL As String = "A"
Const EXCEL_2_COPY_COLS As String = "B,E,G"
Const EXCEL_3 As String = "\Excel3.xls"
Const EXCEL_3_TARGET As String = "B"
Public Function LoadInformation3()
Dim Location As String, Keywords As String
Application.ScreenUpdating = False
Location = Application.ActiveWorkbook.Path
Keywords = LoadKeywords(Location & EXCEL_1, EXCEL_1_KW_COL)
Debug.Print "Keys=" & Keywords
Dim L, CurrentDestRow As Long
For Each L In Split(Keywords, ",")
SearchKeywordAndCopy CurrentDestRow, Location & EXCEL_2, Location & EXCEL3, L, EXCEL_2_KW_COL, EXCEL_2_COPY_COLS, EXCEL_3_TARGET
Next
Application.ScreenUpdating = True
End Function
Public Function LoadKeywords(ByVal File As String, ByVal ColumnId As String, Optional ByVal FirstRow As Long = 2)
Dim Wb1 As Workbook
Dim Value As String, N As Long
Set Wb1 = Workbooks.Open(File)
N = FirstRow
LoadKeywords = ""
Do While True
Value = Wb1.Sheets(1).Range(ColumnId & N).Text
If Value = "" Then Exit Do
LoadKeywords = LoadKeywords & IIf(LoadKeywords = "", "", ",") & Value
N = N + 1
Loop
Wb1.Close SaveChanges:=False
End Function
Public Sub SearchKeywordAndCopy(ByRef CurrentDestRow As Long, ByVal FileSource As String, ByVal FileTarget As String, ByVal Keyword As String, ByVal SourceColumn As String, ByVal SourceCopyFrom As String, ByVal DestCopyTo As String)
Dim WbSource As Workbook, WbDest As Workbook
Dim Value As String, N As Long
Set WbDest = Application.ActiveWorkbook
Set WbSource = Workbooks.Open(FileSource)
N = 2
Do While True
Value = WbSource.Sheets(1).Range(SourceColumn & N).Text
If Value = "" Then Exit Do
If Value <> Keyword Then GoTo NextRow
Dim L, M As Long
CurrentDestRow = CurrentDestRow + 1
WbDest.Sheets(1).Range(DestCopyTo & CurrentDestRow).Value = Keyword
M = 0
For Each L In Split(SourceCopyFrom, ",")
Dim CopyValue As String
CopyValue = WbSource.Sheets(1).Range(L & N).Text
M = M + 1
WbDest.Sheets(1).Range(DestCopyTo & CurrentDestRow).Offset(, M).Value = CopyValue
Next
NextRow:
N = N + 1
Loop
WbSource.Close SaveChanges:=False
End Sub
Your setup as best I could understand it:
And... This is the code I wrote:
Option Explicit
Option Base 1
Sub CopyData()
Dim XLout As Workbook 'Excel_Out.xls
Dim XLin1 As Workbook 'Excel_In1.xls
Dim XLin2 As Workbook 'Excel_In2.xls
Dim ProductList 'Product/Company List from XLin1
Dim ProductListO() 'Concatenated Version of above
Dim DataList 'Product/Company List from XLin2
Dim DataXcol 'Extra Data to pull from Column X in XLin2
Dim DataZcol 'Extra Data to pull from Column Z in XLin2
Dim Output() 'Output Array for XLout
Dim i As Long 'Iterations
Dim counter As Long 'Item number
Dim TimeCount
TimeCount = Timer
' >>> All Workbooks
Set XLout = ThisWorkbook
Set XLin1 = Workbooks.Open("C:\Users\ccritchlow\Documents\A\Test\Excel_In1.xls")
Set XLin2 = Workbooks.Open("C:\Users\ccritchlow\Documents\A\Test\Excel_In2.xls")
' >>> Store Source Data in Arrays
With XLin2.Sheets(1)
DataList = .Range("A2:B" & .Range("A" & Rows.Count).End(xlUp).Row)
DataXcol = .Range("X2:X" & .Range("A" & Rows.Count).End(xlUp).Row)
DataZcol = .Range("Z2:Z" & .Range("A" & Rows.Count).End(xlUp).Row)
End With
' >>> Store Product List Data in Arrays
ProductList = XLin1.Sheets(1).Range("L2:M" & XLin1.Sheets(1).Range("M" & Rows.Count).End(xlUp).Row)
ReDim ProductListO(1 To UBound(ProductList, 1))
For i = 1 To UBound(ProductList, 1)
ProductListO(i) = ProductList(i, 1) & "-" & ProductList(i, 2)
Next i
' >>> Move entries from XLin2 (that exist on XLin1) into "Output" Array
ReDim Preserve Output(UBound(DataList, 1), 3)
counter = 1
For i = 1 To UBound(DataList, 1)
DataList(i, 1) = DataList(i, 1) & "-" & DataList(i, 2)
If Not IsError(Application.Match(DataList(i, 1), ProductListO(), 0)) Then
Debug.Print
Output(counter, 1) = DataList(i, 2)
Output(counter, 2) = DataXcol(i, 1)
Output(counter, 3) = DataZcol(i, 1)
counter = counter + 1
End If
Next i
' >>> Output to XLout
XLout.Sheets(1).Range("A2").Resize(UBound(Output, 1), 3) = Output()
Application.StatusBar = "Total Time to review " & UBound(DataList, 1) & " lines = " & Timer - TimeCount
End Sub
It does the following
Is stored on "Excel_Out.xls"
Opens both "Excel_In#.xls" workbooks
Stores all required data in arrays
Identifies data on XLin2 whose "company&productname" exist on XLin1
Outputs that data to "Excel_Out.xls"
This is how it looks:
I am trying to cycle through names of customers on one sheet (sheet2), take the corresponding value in column J in sheet1 and then paste next to the customers on the original sheet.
This is my code:
For i = 0 To 9
Dim rowi As Long
rowi = Application.WorksheetFunction.Match((Worksheets("Sheet2").Cells(5 + i, 4)), Worksheets("Sheet1").Range("B:B"), 0)
Crystali = Cells(rowi, 10)
Sheets("Sheet2").Activate
Worksheets("Sheet2").Cells(5 + i, 7) = Crystali
Next i
Can someone help me fix it? I keep getting the error "Unable to get the Match property of Worksheetfunction class"
Thanks in advance.
here short example how to use the 'Match()' function without 'worksheet-function' part like Tim suggests. After the Match function was called just check the result with 'IsError()'.
Option Explicit
Public Sub test()
Dim row_index As Long
Dim match_result As Variant
Dim lookup_value As Variant
Dim lookup_array As Variant
Set lookup_array = Range("Sheet1!B:B")
Const FIRST_ROW As Byte = 5
Const LAST_ROW As Byte = 9
For row_index = FIRST_ROW To LAST_ROW
Set lookup_value = Range("Sheet2!D" & row_index)
match_result = Application.Match(lookup_value, lookup_array, 0)
If Not IsError(match_result) Then
' copy data only if Match function found something
Range("Sheet2!G" & row_index) = Range("Sheet1!J" & match_result)
End If
Next row_index
End Sub