TLDR: I need to alter a macro I wrote that selected a range of data based on user input. It originally used the whole range (just consecutive columns), but now needs to select every other column.
I have a sheet I'm working on where the user will input the number of years they want to look at an investment over. Basically, I have 50 years populated, and my macro hides the columns that exceed the specified number of years. Then using the remaining visible range, I have metrics that are run(Net Present Value, Internal Rate of Return). This all worked fine, but I now need to put a percentage column next to the initial data, meaning the metric formulas can't run using the consecutive ranges as they are. They need every other column of visible data.Here
Below is my code:
Sub HideCol()
'Prep the sheet
Sheets("Modeling").Visible = True
Sheets("Modeling").Activate
Columns("C:AZ").Select
Selection.EntireColumn.Hidden = True
myNum = Worksheets("InitialData").Range("LeaseTerm").Value
Range("C1").Select
numrows = Selection.Rows.Count
numColumns = Selection.Columns.Count
Selection.Resize(numrows + 0, numColumns + myNum - 1).Select
Selection.EntireColumn.Hidden = False
'Input dynamic calcs
'This is my problem here. calcrange selects consecutive columns, and I need to do every other
Dim calcrange As Range
Set calcrange = Union(Range("InvestmentOutlay"), Range(Range("B57"), Range("B57").End(xlToRight)))
Range("IRR").Formula = "=IRR(" & calcrange.Address & ")"
Dim npvRange As Range
Set npvRange = Range(Range("C57"), Range("C57").End(xlToRight))
Range("NPV").Formula = "=NPV(EconGrowth," & npvRange.Address & ")"
Dim outF As Range
Dim inF As Range
Set outF = Range("InvestmentOutlay")
Set inF = Range(Range("C57"), Range("C57").End(xlToRight))
Range("PB").Formula = "=PaybackPeriod(" & outF.Address & ", " & inF.Address & ")"
End Sub
Instead of:
Set calcrange = Union(Range("InvestmentOutlay"), Range(Range("B57"), Range("B57").End(xlToRight)))
just add every second column to the Union:
Dim c As Long
Set calcrange = Range("InvestmentOutlay")
For c = 2 To Range("B57").End(xlToRight).Column Step 2
Set calcrange = Union(calcrange, Cells(57, c))
Next
Related
I have a file with more then 1 sheet, where in the Reports Sheet I want to filter by ASBN products and then delete them, because I already processed it in another sheet, so I need to delete the initial ones in order to paste back the processed one.
Idea is that this deleting code which is working, but is taking for at least 20 minutes, because I want to delete 123 572 rows, do you have any idea how could I make this work faster?
I also tried to clear contents first and then to delete empty rows, but it's the same.
Here you find the code:
Public Sub Remove_ABSN()
Dim area As String
Dim start As Long
area = "ABSN"
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.EnableEvents = False
start = Worksheets("Reports").Cells(Cells.Rows.Count, 1).End(xlUp).Row
Worksheets("Reports").Range("$A$2:$AN" & start).AutoFilter Field:=8, Criteria1:=area, Operator:=xlFilterValues
Worksheets("Reports").Range("$A$2:$AN$" & start).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Sheets("Reports").ShowAllData
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
I think AutoFilter will be the fastest way to do it. Here are two sample scripts to try. You can see for yourself which one is faster.
Public Sub UnionDeleteRowsFast()
' Careful...delete runs on Sheet1
Dim sh2 As Worksheet
Set sh2 = Sheets("Sheet1")
Dim lastrow As Long
Dim Rng As Range
lastrow = Cells(Rows.Count, "B").End(xlUp).Row
For i = lastrow To 2 Step -1
If Cells(i, 2).Value = "Delete" Then
If Rng Is Nothing Then
Set Rng = Range("B" & i)
Else
Set Rng = Union(Rng, Range("B" & i))
End If
End If
Next
If Not Rng Is Nothing Then Rng.EntireRow.Delete
End Sub
Sub AutoFilterDeleteRowsFast()
' Careful...delete runs on ActiveSheet
With ActiveSheet
.AutoFilterMode = False
With Range("B4", Range("B" & Rows.Count).End(xlUp))
.AutoFilter 1, "*Delete*"
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete
End With
.AutoFilterMode = False
End With
End Sub
There is a way that is much faster.
Suppose a table of 100,000 lines (A1:B100001) with headers in line 1. Then delete condition refers to just 1 column (B).
One needs a auxiliar column (A) just to count the lines in the original order. Here I use autofill function.
So one can sort the table and after restore the original order.
Below there is a complete example, that generates randomly numbers from 1 to 10 (it's slow!), and after quickly delete all lines with values 3
Sub EraseValue()
Application.ScreenUpdating = False
Dim i As Long
Dim T1 As Single ' milisecs after booting (Start)
Dim T2 As Single ' milisecs after booting (End)
Dim LIni As Variant ' Initial line to delete
Dim LEnd As Variant ' Final line to delete
Const Fin = 100000 ' Lines in the table
Const FinStr = "100001" ' Last line (string)
Randomize (GetTickCount()) ' Seed of random generation
For i = 1 To Fin
Cells(i + 1, "B") = Int(Rnd() * 10 + 1) ' Generates from 1 to 10
If i Mod 100 = 0 Then Application.StatusBar = i
DoEvents
Next i
Application.StatusBar = False
Dim Table As Range
Dim Colu As Range
T1 = GetTickCount() ' Initial time
Cells(2, "A") = 1 ' Starting value
Cells(3, "A") = 2 ' Step
' Fill from 1 to 100,000 step 1
Range("A2:A3").AutoFill Destination:=Range("A2:A" & FinStr)
' Order by condition column
Table.Sort Key1:=Cells(1, "B"), Header:=xlYes
'One needs delete lines with column B = 3
'LIni: Search key that not exceed value 2 in the column
' (2 is immediately previous value)
'LEnd: Search key that not exceed value 3 in the column
'LIni and LFim is relative to 2 so add 1 for skip the header
'Add more 1 to Lini in order to get the first value in the column >= key
'
LIni = Application.Match(2, Colu, 1) + 2
LEnd = Application.Match(3, Colu, 1) + 1
If IsError(LIni) Or IsError(LEnd) Or LEnd < LEnd Then
MsgBox ("There is no lines to delete")
End
End If
Range(Rows(LIni), Rows(LEnd)).Delete (xlUp) ' Delete lines
Table.Sort Key1:=Cells(1, "A"), Header:=xlYes ' Restore initial order
T2 = GetTickCount() ' Get the final time
MsgBox ("Elapsed milisecs: " + Format((T2 - T1), "0"))
End Sub
In my old computer, it take a little bit more that 0.5 secs with 100,000 lines.
If one has a condition that involves 2 columns or more, one need to create an another auxiliary column with a formula that concatenate these columns related do desired condition and run the match in this column. The formula needs to usage relative references. For instance (assuming that the data of column C are string and is already filled with a header).
Cells(1,4) = "NewCol" ' New column D
Dim NewCol As Range
Set NewCol = Range("D2:D" & FinStr)
' Two previous columns concatenated. In line 2
' the formula would be "=Format(B2,"0")+C2" (B2 is a number)
NewCol.FormulaR1C1 = "=Format(RC[-2],"0") & RC[-1]"
NewCol.Copy
NewCol.PasteSpecial(XlValues) ' Convert all formulas to values
Application.CutCopyMode=false
So one usages the column D instead column B
I'm sure this is possible, im just not sure what the code should be. i have 2 sheets: (1)Component which has all the Component Names where an analyst got marked down on, including dates of when the call occurred, and (2)Calculator, which counts the number of times a specific component appeared in a specific week number.
ive created a code which gets the distinct Component Names from the Component Sheet, and then copies and transpose them to the Calculator sheet. all the Component Names are in Row 1 starting from Column D1 then goes to E1, F1, and so on. i want row 2 to display the count or the number of times the component(listed in row 1) appeared in a week.
The code i have only works for columns, i do not know how to make it get the non-empty values of an entire row.
'//here the code i used to transpose Distinct Components from the Component sheet to the Calculator Sheet
Public Sub GetDistinctComponents()
Application.ScreenUpdating = False
Dim lr As Long
lr = Sheets("Components Data").Cells(Rows.Count, "F").End(xlUp).Row
Sheets("Calculator").Unprotect Password:="secret"
Sheets("Components Data").Range("F1:F" & lr).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=ActiveSheet.Range("DW1"), Unique:=True
With ThisWorkbook.Worksheets("Calculator")
.Range(.Range("DW1"), .Range("DW1").End(xlDown)).Copy
.Range("DX1").PasteSpecial xlPasteValues, Transpose:=True
.Columns("DW").EntireColumn.Delete
End With
Sheets("Calculator").Protect Password:="secret", DrawingObjects:=False
End Sub
Here's my Component sheet
And below is my Calculator sheet. as you can see, the code to transpose the distinct Components works fine. i just do not know how to get the value of Row 1 starting from DX so i can store it in a variable which i will use in counting the number of times that component appeared in a week . I'm thinking it should go like this
Component = wsCalculator.Cells(i, "D").Value
But this code only works if i want to get the Values of all cells in Column D, not the values of the cells next to D1
and here's the code i currently have
Public Sub CountComponent()
Application.ScreenUpdating = False
Sheets("Calculator").Unprotect Password:="secret"
Set wsComponentData = Sheets("Components Data")
Set wsCalculator = Sheets("Calculator")
Dim ComponentCount As Integer
'//Get the index of the last filled row based on column A
LastComponentRowIndex = wsComponentData.Cells(Rows.Count, "A").End(xlUp).Row
'//Get Range for ComponentData
Set ComponentRange = wsComponentData.Range("F2:F" & LastComponentRowIndex)
'//Get the index of the last filled row based on column C
LasttotalauditRowIndex = wsCalculator.Cells(Rows.Count, "C").End(xlUp).Row
'//Get range for Calculator
Set MyRange = wsCalculator.Range("C2:C" & LasttotalauditRowIndex)
TotalCalls = WorksheetFunction.Sum(MyRange)
'//Looping through all filled rows in the Components Data sheet
For i = 2 To wsCalculator.Cells(Rows.Count, "A").End(xlUp).Row
'//Get Component from cell in column "DW"
'Component = wsCalculator.Cells(i, "DW").Value
'//Count the # of calls that got hit in the corresponding Component
If wsCalculator.Cells(i, "DW").Value <> "" Then
ComponentCount = Application.WorksheetFunction.CountIf( _
ComponentRange, component)
wsCalculator.Cells(i, "DX").Value = ComponentCount
End If
Next
End Sub
I'll take a crack at this. I'm not 100% sure what you are doing, but I'm going to assume you will have soon calculations in cells D2, down, and to the right. Is that correct? Try this small code sample to copy from D2 (down and right) on the "Components Data" sheet, and transpose to your "Calculator" sheet.
Sub TransposeThis()
Set Rng = Sheets("Components Data").Range("D2:D7") 'Input range of all fruits
Set Rng_output = Sheets("Calculator").Range("B2") 'Output range
For i = 1 To Rng.Cells.Count
Set rng_values = Range(Rng.Cells(i).Offset(0, 1), Rng.Cells(i).End(xlToRight)) 'For each fruit taking the values to the right which need to be transposed
If rng_values.Cells.Count < 16000 Then 'To ensure that it doesnt select till the right end of the sheet
For j = 1 To rng_values.Cells.Count
Rng_output.Value = Rng.Cells(i).Value
Rng_output.Offset(0, 1).Value = rng_values.Cells(j).Value
Set Rng_output = Rng_output.Offset(1, 0) 'Shifting the output row so that next value can be printed
Next j
End If
Next i
End Sub
Before:
After:
If I got something wrong, post your feedback, and I'll adjust the code to suit your needs.
The code below is your own code, in part, which I commented, and of my own making for those parts where you seemed to have lost your way.
Public Sub CountComponent()
' Locations:-
Dim WsComp As Worksheet
Dim WsCalc As Worksheet
Dim CompRng As Range ' column A
Dim CalcRng As Range ' Calculator!D1:D?)
Dim Rt As Long ' Target row (in WsCalc)
' Helpers:-
Dim Cell As Range
Dim R As Long
Set WsComp = Sheets("Components Data")
Set WsCalc = Sheets("Calculator")
WsCalc.Unprotect Password:="secret"
Application.ScreenUpdating = False
'//Get the index of the last filled row based on column A
With WsComp
' observe the leading period in ".Rows.Count"
'LastComponentRowIndex = .Cells(.Rows.Count, "A").End(xlUp).Row
'//Get Range for ComponentData
'Set CompRng = .Range("A2:A" & LastComponentRowIndex)
' avoids the need for decalring LastComponentRowIndex
Set CompRng = .Range(.Cells(2, "A"), _
.Cells(.Rows.Count, "A").End(xlUp))
End With
With WsCalc
' set a range of all criteria to look up
Set CalcRng = .Range(.Cells(1, "D"), _
.Cells(1, .Columns.Count).End(xlToLeft))
'//Get the index of the last non-empty row in column B
' loop through all rows in WsCalc
For R = .Cells(.Rows.Count, "B").End(xlUp).Row To 2 Step -1
If Val(.Cells(R, "B").Value) Then ' presumed to be a week number
'//Loop through all audit criteria
For Each Cell In CalcRng
With .Cells(R, Cell.Column)
.Value = WorksheetFunction.CountIfs( _
CompRng, Cell.Value, _
CompRng.Offset(0, 1), WsCalc.Cells(R, "B").Value)
.NumberFormat = "0;-0;;" ' suppress display of zero
End With
Next Cell
End If
.Cells(R, "C").Value = WorksheetFunction.Sum(CalcRng.Offset(R - 1))
Next R
End With
Application.ScreenUpdating = True
End Sub
Frankly, I couldn't understand all of your intentions. I presumed that column B in your Calculations sheet would contain a week number and that this week number would also be found in the Components Data (in column B). If so, you would be counting the occurrences of each component by week, and that is what I programmed.
I think it doesn't matter if I got that part wrong. Your main question was how to look up each of the Components in Calculations!D1:??. That method is very well demonstrated in my above answer and I feel confident you will be able to transplant the useful bits to your own project. Good luck!
I suggest taking a look at VBA dictionaries. In this case, you could store each component as a key and for the value you can accumulate the number of occurrences of the component for a given week.
I don't have a VBA editor available on my computer at the moment to test this, but it would likely look something along the lines of what I've got below. Also, I'll admit that I may not have fully understood the layout of your sheets, but the general principle here will definitely apply.
For a pretty full overview of dictionaries in VBA, here's a good resource that'd I'd recommend: https://excelmacromastery.com/vba-dictionary/
Public Sub CountComponent()
Application.ScreenUpdating = False
Sheets("Calculator").Unprotect Password:="secret"
Set wsComponentData = Sheets("Components Data")
Set wsCalculator = Sheets("Calculator")
'//Get the index of the last filled row based on column A
LastComponentRowIndex = wsComponentData.Cells(Rows.Count, "A").End(xlUp).Row
'//Get Range for ComponentData
Set ComponentRange = wsComponentData.Range("A2:A" & LastComponentRowIndex)
'//Get the index of the last filled row based on column C
LasttotalauditRowIndex = wsCalculator.Cells(Rows.Count, "C").End(xlUp).Row
'//Get range for Calculator
Set MyRange = wsCalculator.Range("C2:C" & LasttotalauditRowIndex)
TotalCalls = WorksheetFunction.Sum(MyRange)
'// Declare a new dictionary
dim componentDict as New Scripting.Dictionary
'// First loop through the Calculator sheet to get each component
'// and set initial value to zero
dim i as Long, lastCalcColumn as Long
lastCalcColumn = wsCalculator.Cells(1, Columns.count).end(xlToLeft).Column
for i = 4 to lastCalcColumn
'// Adding each item to dictionary, a couple of ways to write this,
'// but this is probably the easiest
componentDict(wsCalculator.Cells(i, 1).Value) = 0
next i
'//Looping through all filled rows in the Components Data sheet
'// I changed this to loop through each row in your component sheet
'// So that we can accumulate the total occurences
dim current_key as String
For i = 2 To LastComponentRowIndex
If wsComponentData.Range("G" & i).Value <> "" Then
'// assuming component names are in the "G" column
'// change this as needed
current_key = wsComponentData.Range("G" & i).Value
componentDict(current_key) = componentDict(current_key) + 1
end if
Next i
'// now back to the Calculator sheet to enter the values
for i = 4 to lastCalcColumn
current_key = wsCalculator.Cells(i, 1).Value
wsCalculator.Cells(i, 2).Value = componentDict(current_key)
next i
End Sub
I need help here. I have a spreadsheet that has more than 6K datas. I need to compare the values between the "MOVE_IN_QTY" and "MOVE_OUT_QTY" by using VBA. The problem here is I need to compare the value right after the code has changed from "CV64" and "TW78" in the code column. The value I have higlighted in red and the code I have highlighted in blue and yellow. I would appreciate any help. Thanks.
Making a few assumptions here:
Move In & Move Out are always numbers.
Move numbers are compered using the =,<,> process.
Unknown further action based on result is required.
Also it helps to include what you have tried and what is not working.
Sub ReviewData()
Dim wkbk As Workbook
Dim xsheet As Worksheet
Dim codeColumn As String, moveIN As String, moveOUT As String
Dim rowCount As Double
Set wkbk = ThisWorkbook
Set xsheet = wkbk.Worksheets("Sheet1") 'change sheet name here
codeColumn = "B" ' change column letter here
moveIN = "C" 'set move in column
moveOUT = "D" 'set move out column
'this will loop through the Code column until the last set of data.
rowCount = xsheet.Range(codeColumn & xsheet.Rows.Count).End(xlUp).Row 'find last row
For x = 2 To rowCount
'checks if code transitions from one code to another
If not xsheet.Range(codeColumn & x).Value = xsheet.Range(codeColumn & x + 1).Value Then
If xsheet.Range(moveIN & x).Value = xsheet.Range(moveOUT & x + 1).Value Then
'do something if the code is the same
Else
xsheet.Range(codeColumn & x).Interior.ColorIndex = 3
MsgBox ("Row: " & x & " is different") 'comment this out not to get the message
End If
Else
End If
Next x
End Sub
I'm looping over values in Column B of the current worksheet. If the value's length is 8 characters, copy the WHOLE row to another sheet.
It is kind of working, but I'm missing around a hundred rows that should have been copied.
I guess it's to do with the format of the cell values in Column B. There are some that are just Text headers which will definitely not meet the criteria. The ones that it should copy are all in this format (Column B):
6008571X
60088242
....
The rows I'm interested in have 8 characters in Column B. The problem is that some of them might be formatted as numbers some as text (or perhaps preceded by ').
Sub aims()
Dim i As Long
'Get the address of the first non blank cell in Row B from the bottom
MyFirstBlankAddress = Range("B1048576").End(xlUp).Offset(1, 0).Address
'Extract the number from the address to get the row number
MyRowNumber = Split(MyFirstBlankAddress, "$")(2)
For i = 1 To MyRowNumber
With Range("B" & i)
If Len(.Value) = 8 Then .EntireRow.Copy Destination:=Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
End With
Next i
End Sub
I was expecting 410 rows copied, while only 276 got copied.
EDIT: I have been reading your answers/suggestions and testing stuff. I've found out that the problem lies elsewhere. My original code identifies the rows in a correct way, it's something to do with copying.
If I change my code to just highlight the matching rows, it matches all the right rows:
If Len(.Value) = 8 Then .EntireRow.Interior.Color = 5296274
I'm sure there is a better way to do the copy/paste, which is where your issue is, but the below works.
Sub aims()
Dim i As Long
Dim vLastRow As Long
Dim s2 As Long
'find last row in sheet, or you could change to find last row in specified column
'Example: Cells = Columns(column number or letter), Cells(1, 1) = Cells(1, column number)
vLastRow = Cells.Find(what:="*", after:=Cells(1, 1), searchorder:=xlByRows, searchdirection:=xlPrevious).Row
s2 = 1
Application.ScreenUpdating = False
For i = 1 To vLastRow
If Trim(Len(CStr(Cells(i, 2)))) = 8 Then
Rows(i).EntireRow.Copy Destination:=Sheets(2).Range(Cells(s2, 1).Address)
s2 = s2 + 1
End If
Next i
Application.ScreenUpdating = True
End Sub
You can try something like this. The below code attempts to copy everything at once instead of having many instances of copy/paste. The two tests are seeing if the trimmed value has a character length of 8 OR if the trimmed value has a character length of 9 but the last character is the apostrophe. If either of these criteria are met, we will add that cell to a Union.
Once the code has looped through all rows, it will copy the entire union at all once
Option Explicit
Sub shooter()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1") '<-- Update
Dim LR As Long, i As Long, Add As Boolean, CopyMe As Range
Dim x As Range
LR = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
For Each x In ws.Range("B2:B" & LR)
Add = False
If Len(Trim(x)) = 8 Then
Add = True
ElseIf Len(Trim(x)) = 9 And Right(Trim(x), 1) = "'" Then
Add = True
End If
If Add Then
If Not CopyMe Is Nothing Then
Set CopyMe = Union(CopyMe, x)
Else
Set CopyMe = x
End If
End If
Next x
If Not CopyMe Is Nothing Then
CopyMe.EntireRow.Copy Destination:=Sheets(2).Range(“A1”)
End If
End Sub
Excel 2010. I am trying to write a macro that could copy a set of data multiple times based on criteria on another sheet, but I've been stuck for a long time. I very much appreciate any help that could be offered to help me solve this problem.
Step 1: In the "Criteria" worksheet, there are three columns in which each row contains a specific combination of data. The first set of combination is "USD, Car".
Criteria worksheet
Step 2: Then the macro will move to the Output worksheet (please refer to the below link for screenshots), and then filter column A and B with the first set of criteria "USD" and "Car" in the "Criteria" worksheet.
Step 3: Afterwards, the macro will copy the filtered data into the last blank row. But the tricky part here is that, the filtered data has to be copied two times (as the "Number of set" column in the "Criteria" tab is 3 in this combination, and it doesn't have to copy the data three times since the filtered data would be treated as the first set of data)
Step4: After the filtered data have been copied, the "Set" column D will need to fill in the corresponding number of set that the rows are in. Therefore, in this 1st example, cell D2 and D8 will have "1" value, cell D14-15 will have "2" value, and cell D16-17 will have "3" value.
Step5: The macro will then move back to the "Criteria" worksheet and continue to based on the 2nd set of combination "USD, Plane" to filter the data in the "Output" worksheet. Again, it will copy the filtered data based on the "Number of set" in the "Criteria" worksheet. This process will continue until all the different combinations in the "Criteria" worksheet have been processed.
Output worksheet
Ok sorry for delay, here is a working version
you just have to add a sheet called "BF" because the autofilter count wasn't working properly so I had to use another sheet
Sub testfct()
Dim ShC As Worksheet
Set ShC = ThisWorkbook.Sheets("Criteria")
Dim EndRow As Integer
EndRow = ShC.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To EndRow
Get_Filtered ShC.Cells(i, 1), ShC.Cells(i, 2), ShC.Cells(i, 3)
Next i
End Sub
Sub Get_Filtered(ByVal FilterF1 As String, ByVal FilterF2 As String, ByVal NumberSetsDisered As Integer)
Dim NbSet As Integer
NbSet = 0
Dim ShF As Worksheet
Set ShF = ThisWorkbook.Sheets("Output")
Dim ColCr1 As Integer
Dim ColCr2 As Integer
Dim ColRef As Integer
ColCr1 = 1
ColCr2 = 2
ColRef = 4
If ShF.AutoFilterMode = True Then ShF.AutoFilterMode = False
Dim RgTotal As String
RgTotal = "$A$1:$" & ColLet(ShF.Cells(1, Columns.Count).End(xlToLeft).Column) & "$" & ShF.Cells(Rows.Count, 1).End(xlUp).Row
ShF.Range(RgTotal).AutoFilter field:=ColCr1, Criteria1:=FilterF1
ShF.Range(RgTotal).AutoFilter field:=ColCr2, Criteria1:=FilterF2
'Erase Header value, fix? or correct at the end?
ShF.AutoFilter.Range.Columns(ColRef).Value = 1
Sheets("BF").Cells.ClearContents
ShF.AutoFilter.Range.Copy Destination:=Sheets("BF").Cells(1, 1)
Dim RgFilt As String
RgFilt = "$A$2:$B" & Sheets("BF").Cells(Rows.Count, 1).End(xlUp).Row '+ 1
Dim VR As Integer
'Here was the main issue, the value I got with autofilter was not correct and I couldn't figure out why....
'ShF.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Rows.Count
'Changed it to a buffer sheet to have correct value
VR = Sheets("BF").Cells(Rows.Count, 1).End(xlUp).Row - 1
Dim RgDest As String
ShF.AutoFilterMode = False
'Now we need to define Set's number and paste N times
For k = 1 To NumberSetsDisered - 1
'define number set
For j = 1 To VR
ShF.Cells(Rows.Count, 1).End(xlUp).Offset(j, 3) = k + 1
Next j
RgDest = "$A$" & ShF.Cells(Rows.Count, 1).End(xlUp).Row + 1 & ":$B$" & (ShF.Cells(Rows.Count, 1).End(xlUp).Row + VR)
Sheets("BF").Range(RgFilt).Copy Destination:=ShF.Range(RgDest)
Next k
ShF.Cells(1, 4) = "Set"
Sheets("BF").Cells.ClearContents
'ShF.AutoFilterMode = False
End Sub
And the function to get column letter using an integer input :
Function ColLet(x As Integer) As String
With ActiveSheet.Columns(x)
ColLet = Left(.Address(False, False), InStr(.Address(False, False), ":") - 1)
End With
End Function