Multiple criteria Closed

Question

Hi, 

I am trying to perform this for several criteria and I only want to return the detail in a specific column of the source data sheet (say detail in column A). Also, I notice that when the existing code is run, the data is split out into referenced sheets (as desired), but there are empty rows where data did not meet criteria. 

I am referring to thread, "Copy rows based on a condition".

Thanks for you help, 

Peter

Peter · Answer

I am referring to thread, "Copy rows based on a condition".

rizvisa1 · Answer

That thread has too many cooks and solutions. Perhaps time to reset. Could you please upload a sample file with sample data etc on some shared site like https://authentification.site and post back here the link to allow better understanding of how it is now and how you foresee.

rizvisa1 · Answer

Purpose:Take data from master sheet and create/append to based on unique values from a column in master sheet Assumptions: 1. Master sheet is called "List". (Change in the code if the name is different) 2. On Master sheet and other sheets, the data starts from row2 and contains the column headers. (Change in the code its is not the case) 3. The unique value based on which data will be cut is used to name the sheets where the data related to that value is to be copied from master. 4. If the sheet where the data is to copied/cut exists, then append to the existing data. (Change in the code its is not the case) 4. If the cut sheet/report does not exists all column are to be copied from master sheet. 5. If the cut sheet/report does exists, only the columns that exist on cut sheet would be copied from master sheet. Steps: 1. Read the assumptions 2. Make a backup copy of the file 3. Press ALT + F11 to start VBE 4. Click on insert and add a new module 5. Paste the code given below 6. Run the macro Sub MoveDataFromMasterToValueBasedSheet() ' Syed Asad Ali Rizvi ' Version 2.0 Dim sMasterSheet As String 'name of the master sheet Dim iBasedOnColumn As Integer 'column number based on which sheets are to be generated Dim bReplace As Boolean ' should new sheet be generated for item based on which data is cut Dim lHeaderRowLocation As Long ' first used row which should be the header row too Dim lMaxUniqueValueCount As Long 'number of unique items on which sheets are to be generated Dim iUniqueItemProcess As Long ' unique item count that is being processed Dim sUniqueValue As String ' the value for which the sheet is being generated Dim bFreshSheet As Boolean ' fresh sheet was created for item Dim sTempSheet As String 'name of a temp sheet for purpose of working Dim sTempSheet2 As String 'temp sheet to compare columns in source and target Dim lResultSheet As Long 'number of rows in the new sheet Dim iFilterCol As Integer 'location of columns on master sheet Dim iResultCol As Integer 'location of column on target sheet Dim bScreenUpdating As Boolean 'current status of screen updating Dim bDisplayAlerts As Boolean ' show show warnings bScreenUpdating = Application.ScreenUpdating bDisplayAlerts = Application.DisplayAlerts On Error GoTo Error_Handle Application.ScreenUpdating = False ' =============================================== ' ######### CUSTOMIZATION START HERE ############ sMasterSheet = "List" ' master sheet iBasedOnColumn = 2 ' unique items on which data would be cut is would on master sheet in this column lHeaderRowLocation = 2 'the row on which the header row is found and is common to all sheets bReplace = False 'should data be cut on new sheets if sheet is present? ' ######### CUSTOMIZATION END HERE ############# ' =============================================== sTempSheet = "tempsheet" ' temp sheet for unique listing based on which sheets would be populated sTempSheet2 = "tempsheet2" ' bFreshSheet = False ' if data was not to be cut on new sheet, was this sheet created as it was not present On Error Resume Next If bDisplayAlerts Then Application.DisplayAlerts = False Sheets(sTempSheet).Delete If (Not bReplace) Then Sheets(sTempSheet2).Delete If bDisplayAlerts Then Application.DisplayAlerts = True On Error GoTo Error_Handle Sheets.Add ActiveSheet.Name = sTempSheet Sheets(sMasterSheet).Select If ActiveSheet.AutoFilterMode Then Cells.Select On Error Resume Next ActiveSheet.ShowAllData On Error GoTo Error_Handle End If Columns(iBasedOnColumn).Select Selection.Copy Sheets(sTempSheet).Select Range("A1").Select ActiveSheet.Paste Application.CutCopyMode = False If (Cells(1, 1) = "") Then lastrow = Cells(1, 1).End(xlDown).Row If lastrow <> Rows.Count Then Range("A1:A" & lastrow - 1).Select Selection.Delete Shift:=xlUp End If End If Columns("A:A").Select Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("B1"), Unique:=True Columns("A:A").Delete Cells.Select Selection.Sort _ Key1:=Range("A2"), Order1:=xlAscending, _ Header:=xlYes, OrderCustom:=1, _ MatchCase:=False, Orientation:=xlTopToBottom 'DataOption1:=xlSortNormal, lMaxUniqueValueCount = Cells(Rows.Count, 1).End(xlUp).Row If (Not bReplace) Then Sheets.Add ActiveSheet.Name = sTempSheet2 Sheets(sMasterSheet).Select Range(Cells(lHeaderRowLocation, 1), Cells(lHeaderRowLocation, Columns.Count)).Copy Sheets(sTempSheet2).Range("A1").PasteSpecial Transpose:=True End If For iUniqueItemProcess = 2 To lMaxUniqueValueCount sUniqueValue = Sheets(sTempSheet).Range("A" & iUniqueItemProcess) bFreshSheet = False If sUniqueValue <> "" Then On Error Resume Next Err.Clear Sheets(sUniqueValue).Select On Error GoTo Error_Handle If ((ActiveSheet.Name <> sUniqueValue) Or (bReplace)) Then On Error Resume Next If bDisplayAlerts Then Application.DisplayAlerts = False Sheets(sUniqueValue).Delete If bDisplayAlerts Then Application.DisplayAlerts = True On Error GoTo Error_Handle Err.Clear Sheets.Add ActiveSheet.Name = sUniqueValue Sheets(sUniqueValue).Range(lHeaderRowLocation & ":" & lHeaderRowLocation) = Sheets(sMasterSheet).Range(lHeaderRowLocation & ":" & lHeaderRowLocation).Value bFreshSheet = True End If If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False lResultSheet = Cells.Find("*", Cells(1, 1), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row lResultSheet = lResultSheet + 1 Cells(lResultSheet, "A").Select Sheets(sMasterSheet).Select Range(Cells(lHeaderRowLocation, 1), Cells(Rows.Count, Columns.Count)).Select If ActiveSheet.AutoFilterMode = False Then Selection.AutoFilter End If Selection.AutoFilter Field:=iBasedOnColumn, Criteria1:="=" & sUniqueValue, Operator:=xlAnd, Criteria2:="<>" lastrow = Cells(Rows.Count, iBasedOnColumn).End(xlUp).Row If (lastrow > lHeaderRowLocation) Then If bFreshSheet Then Rows(lHeaderRowLocation + 1 & ":" & lastrow).Copy Sheets(sUniqueValue).Range("A" & lResultSheet).PasteSpecial Else lResultSheet = Sheets(sUniqueValue).Cells.Find("*", Cells(1, 1), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row lResultSheet = lResultSheet + 1 Sheets(sUniqueValue).Select Range(Cells(lHeaderRowLocation, 1), Cells(lHeaderRowLocation, Columns.Count)).Copy Sheets(sTempSheet2).Select Sheets(sTempSheet2).Range("B1").PasteSpecial Transpose:=True iResultCol = Cells(Rows.Count, "B").End(xlUp).Row Do While (iResultCol > 0) iFilterCol = 0 On Error Resume Next iFilterCol = WorksheetFunction.Match(Sheets(sTempSheet2).Cells(iResultCol, "B"), Sheets(sTempSheet2).Range("A1:A" & Rows.Count), 0) On Error GoTo Error_Handle If (iFilterCol > 0) Then Sheets(sMasterSheet).Select Range(Cells(lHeaderRowLocation + 1, iFilterCol), Cells(lastrow, iFilterCol)).Copy Sheets(sUniqueValue).Select Cells(lResultSheet, iResultCol).Select ActiveSheet.PasteSpecial End If iResultCol = iResultCol - 1 Loop Sheets(sUniqueValue).Select Cells(lResultSheet, 1).Select End If End If End If Next If bDisplayAlerts Then Application.DisplayAlerts = False Sheets(sTempSheet).Delete If (Not bReplace) Then Sheets(sTempSheet2).Delete If bDisplayAlerts Then Application.DisplayAlerts = True Sheets(sMasterSheet).Select If ActiveSheet.AutoFilterMode Then Cells.Select ActiveSheet.ShowAllData End If GoTo End_Sub Error_Handle: MsgBox Err.Description End_Sub: Application.ScreenUpdating = bScreenUpdating Application.DisplayAlerts = bDisplayAlerts End Sub

Multiple criteria

3 responses

Similar discussions

Subscribe To Our Newsletter!