I need to search similar string which exist under same column from a input excel file and group them together and perform some calculation.
Example say : I have input file named : Predictions
FUND_NAME CLASS_NAME FUND_CODE CASHFLOW_IN_FUND_CURRENCY
AA BB SSIS 19200
VV DD SPIS 16200
QQ NN BNIS 15830
CC DJ SSIS -6300
I want a code in VBA which should combine Similar Fund_Codes together and perform some logical calculations on CASHFLOW_IN_FUND_CURRENCY .
Say When 1st nd 4th row has same fund code (SSIS) then I need to ABS(sum(19200-6300))
I know the logic for calculations ,but couldn't find the logic to group the fund_code within same worksheet and same column.
I had tried the Rachels method fuzzy logic in stack overlow but it didn't work ,
I also tried the below code and it did not work .
Dim ws As Worksheet
Dim lRow As Long, i As Long
Set ws = ThisWorkbook.Sheets("TRANS")
Dim rngFundCode As Range
lRow = Sheet1.Range("C" & Rows.Count).End(xlUp).Row
Set rngFundCode = Range("C:C")
For i = 2 To lRow
Cells(i, 3) = Application.WorksheetFunction.VLookup(Cells(i, 1), rngFundCode, 2, False)
Next i
Could anyone ,let me know how to group the similr string within same column and prform some logic calculation on the other column
Dim ws As Worksheet
Dim lRow As Long, i As Long
Set ws = ThisWorkbook.Sheets("TRANS")
Dim rngFundCode As Range
lRow = Sheet1.Range("C" & Rows.Count).End(xlUp).Row
Set rngFundCode = Range("C:C")
For i = 2 To lRow
Cells(i, 3) = Application.WorksheetFunction.VLookup(Cells(i, 1), rngFundCode, 2, False)
Next i
I want a code in VBA which should combine Similar Fund_Codes together and perform some logical calculations on CASHFLOW_IN_FUND_CURRENCY .
Say When 1st nd 4th row has same fund code (SSIS) then I need to ABS(sum(19200-6300))
I created a class and got the values as a collection from the input file and got this resolved.
Function CalculateReport() As Boolean
Dim bOutput As Boolean: bOutput = False
Dim colPrediction As Collection
Dim objPred As clsPrediction
Dim shtPred As Worksheet
Dim colFunds As New Collection
On Error GoTo ErrorAccessingFile
Set shtPred = g_colInputFiles("txtPredictions").GetSheets(1).GetSheet
On Error GoTo 0
'Get Data from Input Files
Set colPrediction = GetPredictionData(shtPred)
Dim col As Collection
'Split the data by FundCode
For Each objPred In colPrediction
If ItemIsInCollection(colFunds, objPred.Fund_Code) Then
Set col = colFunds(objPred.Fund_Code)
col.Add objPred, objPred.getKey
Else
Set col = New Collection
col.Add objPred, objPred.getKey
colFunds.Add col, objPred.Fund_Code
End If
Next objPred
For Each col In colFunds
If col.Count > 1 Then
'Apply Formula
End If
Next col
Related
I am trying to write a VBA code where I want to populate DATA from a worksheet Range A to AQ spanning over multiple Rows. AQ contains Value "Open" or "Closed". I want to get the rows where AQ value is closed. I tried using the AutoFilter. This is working fine to an extent. But I have to use 2 For loops. One for Each Row and another for Each Column to populate Row wise, column by column into the list box
My Code as follows:
Note : Actual contents start from 6th Row where 6 contains the headers and data starts from 7th Row
Dim i As Long
Dim rowRange As Range
Dim AllData(1 To 1000, 1 To 43) As String
lstRecords.ColumnCount = 43
Set shDSR = mydata1.Sheets("DSR")
last_Row = shDSR.Cells(Rows.Count, 1).End(xlUp).Row
shDSR.AutoFilterMode = False
shDSR.Range("A6:AQ" & last_Row).AutoFilter Field:=43, Criteria1:="CLOSED"
Set rng = shDSR.Range("A6:AQ" & last_Row).SpecialCells(xlCellTypeVisible)
Dim filtrRow() As String
Dim rowCnt As Long
'Me.lstRecords.Clear
rowCnt = 0
If rng.Count > 0 Then
Me.lstRecords.Clear
Me.lstRecords.ColumnCount = rng.Columns.Count
For Each Row In rng.Rows
Me.lstRecords.AddItem
rowCnt = rowCnt +1
filterRow = Range(Row.Address)
'Me.lstRecords.List() = filterRow ''This throws error Type Mismatch so not using
For i = 1 To Row.Columns.Count
AllData(rowCnt, i) = Row.Cells(1, i).Value ''Move to Array
Me.lstRecords.List(rowCnt - 1, i - 1) = filterRow(1, i)'Buggy error when i = 11
Next
Next
'' Following segment works. Add data to Array and then populate ListBox from Array
Me.lstRecords.List() = AllData
Else
MsgBox "No data matches the filter criteria."
End If
Above Code has both approaches
a) Trying to load directly from excel Range (actually using filterRow, but can also directly use range with same issue). But, this approach stops always when i=11 with Invalid property error. I tried changing the data contents etc still same issue
Another Issue when Not taking the array based approach, only one line is added, so in affect only last line is available in the list box
b) Using the AllData array. I load all the row data (matching criteria) into the array and finally populate the listbox from array. THIS WORKS. But I do not like this approach
Can some one please point out where it is going wrong.
Thanks in advance
Problem is that filters create a non contiguous range consisting of areas which you have to iterate separately.
Option Explicit
Sub demo()
Dim mydata1 As Workbook, shDSR As Worksheet
Dim rng As Range, a As Range, r As Range
Dim last_row As Long, n As Long
Dim i As Long, rowCnt As Long
Dim ListData() As String
' change this
Set mydata1 = ThisWorkbook
Set shDSR = mydata1.Sheets("DSR")
With shDSR
.AutoFilterMode = False
last_row = .Cells(.Rows.Count, "AQ").End(xlUp).Row
.Range("A6:AQ" & last_row).AutoFilter Field:=43, Criteria1:="CLOSED"
Set rng = .Range("A6:AQ" & last_row).SpecialCells(xlCellTypeVisible)
.AutoFilterMode = False
End With
' clear listbox
With Me.lstRecords
.Clear
.ColumnCount = rng.Columns.Count
End With
'iterate areas and rows to count visible rows
For Each a In rng.Areas
n = n + a.Rows.Count
Next
rowCnt = 0
If n > 1 Then
' size array
ReDim ListData(1 To n, 1 To rng.Columns.Count)
' fill array
For Each a In rng.Areas
For Each r In a.Rows
rowCnt = rowCnt + 1
For i = 1 To UBound(ListData, 2)
ListData(rowCnt, i) = r.Cells(1, i).Value ''Move to Array
Next
Next
Next
' populate ListBox from Array
Me.lstRecords.List() = ListData
Else
MsgBox "No data matches the filter criteria."
End If
End Sub
Is anyone can help me, pls take a look at the picture i attached.
I want to compare 2 pair of data from 2 different excel file, Station (left file column B) with Station (right file column A) AND Time (left file row 1) with Tendancy (right file Column F).
The left file is the report that im about to finished, the right file is the reference data. If the station and the time data is match each other, it will filled with "1", if not it will stay empty.
The data will start filling from cell C2 until Z32. Im stuck with FOR and IF looping i used. And here's the example:
Cell C2 will filed with "1" bcs there is station 2000001 (cell A2) at 00UTC (cell F2) on the right file.
Cell E2 will stay empty bcs there is station 2000001 BUT NOT at 02UTC on the right file.
Cell C3 will stay empty bcs there is station 2000002 BUT NOT at 00UTC on the right file.
Dim countSM As Long
Dim countSS As Long
Dim countWM As Long
Dim countWS As Long
Dim resultCol As Long
Dim resultRow As Long
Dim lastSM As Long
Dim lastSS As Long
Dim lastWM As Long
Dim lastWS As Long
Dim lastRCol As Long
Dim lastRRow As Long
lastSM = wb1.Sheets("Sheet1").Cells(Rows.count, 1).End(xlUp).Row
lastSS = wb2.Sheets("Worksheet").Cells(Rows.count, 1).End(xlUp).Row
lastWM = wb1.Sheets("Sheet1").Cells(1, Columns.count).End(xlToLeft).Column
lastWS = wb2.Sheets("Worksheet").Cells(Rows.count, 1).End(xlUp).Row
lastRCol = wb1.Sheets("Sheet1").Cells(1, Columns.count).End(xlToLeft).Column
lastRRow = wb1.Sheets("Sheet1").Cells(Rows.count, 1).End(xlUp).Row
For countSM = 2 To lastWM
For countSS = 2 To lastWS
If wb1.Sheets("Sheet1").Cells(countSM, "B") = wb2.Sheets("Worksheet").Cells(countSS, "A") Then
For countWM = 3 To lastWM
For countWS = 2 To lastWS
If wb1.Sheets("Sheet1").Cells(1, countWM) = wb2.Sheets("Worksheet").Cells(countWS, "F") Then
For resultRow = 2 To lastRRow
For resultCol = 3 To lastRCol
wb1.Sheets("Sheet1").Cells(resultRow, resultCol) = "1"
Next resultCol
Next resultRow
Next countSS
ElseIf wb1.Sheets("Sheet1").Cells(1, countWM) <> wb2.Sheets("Worksheet").Cells(countWS, "F") Then
wb1.Sheets("Sheet1").Cells(resultRow, resultCol) = ""
Next countWM
End If
Next countSS
ElseIf wb1.Sheets("Sheet1").Cells(countSM, "B") <> wb2.Sheets("Worksheet").Cells(countSS, "A") Then
wb1.Sheets("Sheet1").Cells(resultRow, resultCol) = ""
Next countSM
End If
I made a code that may work for you. Just count how many rows got the station and UTC value you want to check. If the answer is zero, leave the cell empty. If not, then return 1.
My code is designed on same workbook but it can be adapted yo work with 2 different workbooks easily.
My fake dataset:
My code:
Sub test()
'<------>
'
'
'
'
'YOUR CODE TO OPEN BOTH FILES
'
'
'
'<---->
Dim LeftSheet As Worksheet
Dim RightSheet As Worksheet
Dim MyData As Range 'range to store the data (right file)
Dim LR As Long 'Last row of left file, column Station
Dim LC As Long 'Lastcolumn of left file, (whatever UTC it is)
Dim i As Long
Dim zz As Long
Dim MiF As WorksheetFunction
Set MiF = WorksheetFunction
Dim MyStation As String
Dim MyUTC As String
'Probably you'll need just to adjust references to worksheets from different workbooks
Set LeftSheet = ThisWorkbook.Worksheets("Destiny")
Set RightSheet = ThisWorkbook.Worksheets("Source")
'we store all data into array
Set MyData = RightSheet.Range("A1").CurrentRegion
'data starts at index 2, and we want data from columns 1 and 6 on the range
'Columns 1 and 6 mean columns A and F
'I guess maybe you'll need to adapt this too.
With LeftSheet
LR = .Range("B" & .Rows.Count).End(xlUp).Row
LC = .Cells(1, .Columns.Count).End(xlToLeft).Column
'we count how many rows got the station and tendancy value (intersection) on the right file
' if the count is 0, do nothing. If not zero, return 1 on the cell
'our references will be always at column 2 and row 1
For i = 2 To LR Step 1 'we start at row 2 on left file
MyStation = .Range("B" & i).Value
For zz = 3 To LC Step 1 'we start at column 3, that means column C
MyUTC = .Cells(1, zz).Value
If MiF.CountIfs(MyData.Columns(1), MyStation, MyData.Columns(6), MyUTC) <> 0 Then .Cells(i, zz).Value = 1
Next zz
Next i
End With
'clean variables
Set MyData = Nothing
Set LeftSheet = Nothing
Set RightSheet = Nothing
End Sub
Output after executing code:
Give this solution a try:
Option Explicit
Private Type TWorksheetData
WrkSheet As Worksheet
LastRow As Long
LastColumn As Long
End Type
Sub CopyCompare()
'Organize the variables by referenced worksheet
Dim worksheetData As TWorksheetData
Dim sheet1Data As TWorksheetData
'your solution will provide separate Workbooks for the code below
'ActiveWorkbook (in my case) had both worksheets in order to develop the solution
sheet1Data = SetupWorksheetData(Application.ActiveWorkbook, "Sheet1", sheet1Data)
worksheetData = SetupWorksheetData(Application.ActiveWorkbook, "Worksheet", worksheetData)
Dim refData As Dictionary
Set refData = New Dictionary
'Load the reference data (key = station, value = collection of UTCs)
Dim station As Long
Dim countRow As Long
For countRow = 2 To worksheetData.LastRow
station = CLng(worksheetData.WrkSheet.Range("A" & CStr(countRow)).Value)
If Not refData.Exists(station) Then
refData.Add station, New Collection
End If
refData(station).Add worksheetData.WrkSheet.Range("F" & CStr(countRow)).Value
Next countRow
'Load the UTC header columns from Sheet1
Dim outputMap As Dictionary '(key = UTCXX, value = column Number)
Set outputMap = LoadUTCHeaderColumns(sheet1Data)
'Operate on the Sheet1 data to set the value
For countRow = 2 To sheet1Data.LastRow
station = CLng(sheet1Data.WrkSheet.Range("B" & CStr(countRow)).Value)
Dim utcRef As Variant
If refData.Exists(station) Then
Dim utc As Variant
For Each utc In refData(station)
If InputSheetHasUTCEntry(utc, outputMap) Then
sheet1Data.WrkSheet.Cells(countRow, outputMap(utc)) = "1"
End If
Next
End If
Next countRow
End Sub
Private Function InputSheetHasUTCEntry(ByVal utc As String, ByVal outputMap As Dictionary) As Boolean
InputSheetHasUTCEntry = False
Dim utcRef As Variant
For Each utcRef In outputMap.Keys
If utc = utcRef Then
InputSheetHasUTCEntry = True
Exit Function
End If
Next utcRef
End Function
Private Function LoadUTCHeaderColumns(ByRef sheetData As TWorksheetData) As Dictionary
Set LoadUTCHeaderColumns = New Dictionary
Dim columnHeader As String
Dim outputCol As Long
For outputCol = 1 To sheetData.LastColumn
columnHeader = sheetData.WrkSheet.Cells(1, outputCol).Value
If InStr(columnHeader, "UTC") > 0 Then
LoadUTCHeaderColumns.Add columnHeader, outputCol
End If
Next outputCol
End Function
Private Function SetupWorksheetData(ByVal wb As Workbook, ByVal sheetName As String, ByRef wrksheetData As TWorksheetData) As TWorksheetData
SetupWorksheetData = wrksheetData
Set SetupWorksheetData.WrkSheet = wb.Sheets(sheetName)
SetupWorksheetData.LastRow = SetupWorksheetData.WrkSheet.Cells(Rows.Count, 1).End(xlUp).Row
SetupWorksheetData.LastColumn = SetupWorksheetData.WrkSheet.Cells(1, Columns.Count).End(xlToLeft).Column
End Function
Solution comments:
Loads static reference data from from sheet Worksheet (recommend a different sheet name)
Loads static column number information from Sheet1
There are lots of variables holding similar data for each worksheet used. This indicates an opportunity for using a UserDefinedType (TWorksheetData in this case). This organizes and reduces the number of variables to declare and track.
#1 and #2 uses a Dictionary to retain and correlate static information (requires adding a reference to the Microsoft Scripting Runtime).
Other comments:
(Best Practice) Always declare Option Explicit at the top of modules. Forces all variables used to be declared.
(Best Practice) Don't Repeat Yourself (DRY) - there is a lot of repeated expressions in the original code. This is especially important with Strings. More could be done with the solution provided, but (for example) you will notice that the worksheet name strings only appear once.
I struggle with VBA and have spent a few days trying to find a solution to this problem. Essentially, I have two spreadsheets with large sets of data. Column K of "Design Mods" worksheet contains the same types of values as Column C of the "Output" Worksheet. I've been trying to get my script to do the following:
1. for each cell in column k of "Design Mods", check if there is a matching cell in column c of the "output" spreadsheet
2. if a match is found, then populate the cell in "Design Mods" to columns over with the information from column b of "Output"
Because of my lack of experience, I've only been able to setup the script below which only checks and pulls correctly for one cell.
I need it to check each cell against a range of other cells.
Any help/guidance would be very much appreciated.
Thank you very much!
Sub MatchValue_Test()
'Routine is meant to populate columns "Design Mods" Spreadsheet with affected calculations from the "Output" Spreadsheet
'Variables below refer to Design Mods spreadsheet
Dim designmod As Worksheet '<-- Design Mods worksheet that we are comparing to the Output Data
Dim DesignMod_DClrow As Integer '<-- Variable used to count to the last low in the DC Number Column of Design Mods Spreadsheet
Dim designmoddc As Range '<-- Variable used to identify the range of values being checked in Design Mods is the DC Numbers Column K from K4 to the end of the column
Dim valuetofind As String '<-- DC Number used as matching criteria between Design Mods spreadsheet and Output Data
'Test Variables for integrating references to from Output worksheet
Dim testset As Worksheet
Dim test2_lrow As Integer
Dim test As Range
Dim valuetofindw2 As String
'Variables below pertain the routine itself
Dim found As Boolean '<-- this condition has to be false to start the routine
'Start of Routine
found = False
'Definition of Data Ranges in Design Mods spreadsheet
Set designmod = ActiveWorkbook.Worksheets("Sheet1")
DesignMod_DClrow = designmod.Range("K4").End(xlDown).Row
Set designmoddc = designmod.Range("K4:K" & DesignMod_DClrow)
'Test variables for integrating values from Output worksheet
Set testset = ActiveWorkbook.Worksheets("Sheet2")
test2_lrow = testset.Range("C2").End(xlDown).Row
Set test = testset.Range("C2:C" & test2_lrow)
'Identify the value being matched against
valuetofind = designmod.Range("L4").Value '<-- the script wont run if I have this value set to a range, and I need to figure out get this to loop so I don't need a variable for every cell im checking against
'test variables to figure out if statement
valuetofindw2 = testset.Range("C2").Value
valuetofindw3 = testset.Range("B2").Value
valuetofindw4 = designmod.Range("K4")
'If Statements performing the comparison
For Each Cell In designmoddc
If Cell.Value = valuetofindw3 Then
found = True
End If
Next
If found = True Then
designmoddc.Cells.Offset(0, 2).Value = testset.Range("B2")
End If
End Sub
You did not answer my clarification questions...
I prepared a solution, able to work very fast (using arrays). Please back-up your workbook, because the code will rewrite the matching cases in column M:M.
Sub MatchValue_TestArrays()
Dim designMod As Worksheet, lastRowD As Long, testSet As Worksheet, lastRowT As Long
Dim arrDes As Variant, arrTest As Variant, d As Long, t As Long, boolFound As Boolean
Set designMod = Worksheets("Sheet1")
Set testSet = Worksheets("Sheet2")
lastRowD = designMod.Range("K" & Cells.Rows.Count).End(xlUp).Row
lastRowT = testSet.Range("C" & Cells.Rows.Count).End(xlUp).Row
arrDes = designMod.Range("K4:M" & lastRowD).value 'load the range in array
arrTest = testSet.Range("B2:C" & lastRowT).value
For d = 1 To UBound(arrDes, 1)
For t = 1 To UBound(arrTest, 1)
If arrDes(d, 1) = arrTest(t, 2) Then
arrDes(d, 3) = arrTest(t, 1)'fill the array third column (M:M) with values of B:B testSheet...
Exit For
End If
Next t
Next d
designMod.Range("K4:M" & lastRowD).value = arrDes' Drop the modified array
End Sub
Try the updated code, please. It searches now for all occurrences and put each one in a consecutive column:
Sub MatchValue_TestArrays_Extended()
Dim designMod As Worksheet, lastRowD As Long, testSet As Worksheet, lastRowT As Long
Dim arrDes As Variant, arrTest As Variant, d As Long, t As Long, col As Long
Set designMod = Worksheets("Design") ' Worksheets("Sheet1")
Set testSet = Worksheets("TestS") ' Worksheets("Sheet2")
lastRowD = designMod.Range("K" & Cells.Rows.Count).End(xlUp).Row
lastRowT = testSet.Range("C" & Cells.Rows.Count).End(xlUp).Row
arrDes = designMod.Range("K4:AQ" & lastRowD).value
arrTest = testSet.Range("B2:C" & lastRowT).value
For d = 1 To UBound(arrDes, 1)
col = 3 'the column where the occurrence will be put
For t = 1 To UBound(arrTest, 1)
If arrDes(d, 1) = arrTest(t, 2) Then
arrDes(d, col) = arrTest(t, 1): col = col + 1
End If
Next t
Next d
designMod.Range("K4:AQ" & lastRowD).value = arrDes
End Sub
Using Match() is fast when your data is on a worksheet:
Sub MatchValue_Test()
Dim wsDesign As Worksheet, wsOut As Worksheet, m, c As Range
Set wsDesign = ActiveWorkbook.Worksheets("Sheet1")
Set wsOut = ActiveWorkbook.Worksheets("Sheet2")
For Each c In wsDesign.Range(wsDesign.Range("K4"), _
wsDesign.Cells(Rows.Count, "k").End(xlUp)).Cells
m = Application.Match(c.Value, wsOut.Columns("C"), 0)
If Not IsError(m) Then
'if Match() found a hit then m will be the row number on sheet2
c.Offset(0, 2).Value = wsOut.Cells(m, "B").Value
End If
Next c
End Sub
I know this topic has been asked about before but nothing quite covers what I need. So here's the thing..
I have two workbooks. One is exported from another program which shows a staff member's Surname, first name, email and which ward they work on.
[Workbook1 example]
The second is the full staff list which has the same details but also a check list column.
[Workbook2 example]
What I need is a macro (probably a vlookup) which takes the information from the workbook1, checks against surname, first name and ward on workbook2 to ensure that it is the correct member of staff, copies the email onto workbook 2 and also fills the checklist column on workbook 2 to "Yes".
I'm afraid I am at a loss as to how to incorporate all of this together. Please help.
This is what I have so far but my knowledge is limited and did not know how to proceed.
Private Sub UpdateTraining_Click()
Dim I As Integer
Dim Ws1 As Worksheet
Dim Ws2 As Worksheet
Dim Ws3 As Worksheet
Dim Wb As Workbook
Dim CopyData As String
Dim RwCnt As Long
Dim RwCnt2 As Long
Dim Rw As Long
Dim Clm As Long
Dim SName As String
Dim FName As String
Dim Wrd As String
Dim vArr
Dim ClmLet As String
Set Ws1 = Workbooks("Nursing Docs Training Record.xlsm").Worksheets("Staff Training Record")
Set Ws2 = Workbooks("Nursing Docs Training Record.xlsm").Worksheets("Do Not Use")
Workbooks.Open ("C:\TypeformNursingDocumentation.xlsx")
Set Ws3 = Workbooks("TypeformNursingDocumentation.xlsx").Worksheets("tWeXNp")
RwCnt = Ws3.Cells(Rows.Count, 1).End(xlUp).Row
RwCnt2 = Ws1.Cells(Rows.Count, 1).End(xlUp).Row
Rw = Ws3.Range("F2").Row
Clm = Ws3.Range("F2").Column
Table1 = Ws3.Range("F2:F" & RwCnt)
vArr = Split(Cells(1, Clm).Address(True, False), "$")
ClmLet = vArr(0)
For Each cl In Table1
Ws3.Range(ClmLet & Rw).Select
SName = ActiveCell.Value
FName = ActiveCell.Offset(0, -1).Value
Wrd = ActiveCell.Offset(0, -4).Value
Rw = Rw + 1
Next cl
End Sub
You can achieve this with formulas but then you have to open Workbook1 for the formulas to work in Workbook2. So below approach uses VBA to achieve the results
Copy the below UDF in a module in Workbook2:
Sub UpdateMyList()
Dim oSourceWB As Workbook
Dim oSourceR As Variant
Dim iTotSRows&, iTotCRows&, iCC&, iSC&
Dim oCurR As Variant
Application.ScreenUpdating = False
' First lets get source data
Set oSourceWB = Workbooks.Open("C:\Temp\EmpLookup.xlsx", ReadOnly:=True) ' Change the source file name
With oSourceWB.Worksheets("Sheet1") ' Change the source sheet name
iTotSRows = .Range("A" & .Rows.count).End(xlUp).Row
oSourceR = .Range("A2:G" & iTotSRows)
End With
oSourceWB.Close False
' We now need the data from the sheet in this workbook to compare against
With ThisWorkbook.Worksheets("Sheet8") ' Change the sheet name to the sheet in your workbook
iTotCRows = .Range("A" & .Rows.count).End(xlUp).Row
oCurR = .Range("A2:H" & iTotCRows)
End With
' Next, lets compare and update fields
For iCC = 1 To UBound(oCurR)
For iSC = 1 To UBound(oSourceR)
If (oCurR(iCC, 1) = oSourceR(iSC, 6)) And (oCurR(iCC, 2) = oSourceR(iSC, 5)) And (oCurR(iCC, 5) = oSourceR(iSC, 2)) Then
oCurR(iCC, 7) = oSourceR(iSC, 7)
oCurR(iCC, 8) = "Yes"
Exit For
End If
Next
Next
Application.ScreenUpdating = True
' Finally, lets update the sheet
ThisWorkbook.Worksheets("Sheet8").Range("A2:H" & iTotCRows) = oCurR
End Sub
I've commented on the lines where you need to change references to workbook or worksheets. As long as you have updated the workbook and worksheet references, this should give you the desired results
I built the above UDF based on the columns as you provided in your question. If the columns change, you will have to modify the UDF or get the columns dynamically
You can use and If(Countif()) style function, where the countif checks for the presence of your value, and the if will return true if it is a match, then you can use the if true / false values accordingly. Let me know if you need more details but it could look something like this =IF(COUNTIF(The selected cell is in the selected range),"Yes", "No"). Then record this as a macro and copy the code into yours.
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