Filtering and generating new tabs based on Unique values based in column

**amlan009** · 07-01-2012, 12:43 AM

Dear ,

For understanding this project ,please see the attached workbook's......

The first one "Input "see the tab called final ,

Now ,please open the spreadsheet input 1 and see tab Final 2.......

The only difference between Final and final 2 is that the blank rows (Note it does have value in cell H -But for my purpose any row with value just in H is a blank row and needs to be deleted and new tab needs to be prepared exactly like final 1 ......

Now in final 2,you will see that i fill blank entries in column E as NOT FOUND ,

Now see attached sheet DBC project filter Output sheet ....you will note that based on unique values in column E ,seperate tabs are created -i did use datapig explosion for the purpose but wish that i can have a macro for the purpose ...

Also you will note that the attached macro already has a subroutine defined which generates the final sheet based on content of sheet 1 and sheet 2 .......

(is it possible that you make this macro and call oit from the first macro so that on single click of the first subroutine ,all the filtering and then further tabbing takes place )
Anyways ,just making a mcro for the thread will solve my worry ,since i can then easily call the macro from the first macro myself ,

Thanks in advance ,

Regards ,

Amlan Dutta

**amlan009** · 07-01-2012, 07:00 AM

I have got great help from Zbor for the first part of the case in thread at link
http://www.excelforum.com/excel-misc...ate-tab-2.html

->wherein solely because of his input, the first first part of it stays solved

In the main routine i call the following 2 subroutines which helps me achieve what i want in terms changing to uppercase ,also of deletion of blank rows and insertion of "NOT FOUND"in empty E cells ,

The subroutines go like this ,


Sub Uppercase()


Dim x As Variant
Dim LR As Long

 LR = Cells(Rows.Count, "E").End(xlUp).Row 'Last row number
      
      For x = LR To 3 Step -1
      'Loop to cycle through each cell in the specified range.
      
        Range("E" & x).Value = UCase(Range("E" & x).Value) 'Change the text in the range to uppercase letters.
     
     If Range("A" & x).Value = "" Then 'Check is value in A row empty
        Range("A" & x).EntireRow.Delete 'Delete entire row
        End If
    
        
     Next x
End Sub

Sub notfound()
        
        
Dim x As Variant
Dim LR As Long

 LR = Cells(Rows.Count, "E").End(xlUp).Row 'Last row number
      
      For x = LR To 3 Step -1
     
      'Loop to cycle through each cell in the specified range.
      
      If Range("E" & x).Value = "" Then 'Check whether Value in E is empty
        Range("E" & x).Value = "Not Found " 'Puts "Not Found in In it "
        End If
        
        Next x
        
        End Sub

Please find input and output file attached,

Now main task remains filtering into seperate tabs based on unique values in Column E and naming the tabs after those unique values in E ,

I repeat that first part of the project has become possible to solve due to thread at

http://www.excelforum.com/excel-misc...ate-tab-2.html

Now only i need to filter tabs based on unique values in column E

Appreciate if i recieve some help there ,

Regards ,

Amlan

**nilem** · 07-01-2012, 09:10 AM

Hi Amlan, try this

Sub ertert()
Dim x, i&: Application.ScreenUpdating = 0
With Sheets("Final")
    x = .Range("E3", .Cells(Rows.Count, 5).End(xlUp)).Value
End With

With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 1 To UBound(x)
        If Not .Exists(x(i, 1)) Then
            .Item(x(i, 1)) = 1
            If Not Evaluate("ISREF('" & x(i, 1) & "'!A1)") Then
                Sheets.Add(after:=Sheets(Sheets.Count)).Name = x(i, 1)
            End If
        End If
    Next i: x = .keys
End With

With Sheets("Final")
    With .Range("A2:O" & .Cells(Rows.Count, 1).End(xlUp).Row)
        .AutoFilter
        For i = 0 To UBound(x)
            .AutoFilter Field:=5, Criteria1:=x(i)
            .SpecialCells(12).Copy Sheets(x(i)).Range("A2")
'            Sheets(x(i)).Shapes(1).Delete
        Next i
        .AutoFilter
    End With
End With: Application.ScreenUpdating = 1
End Sub

Also try this line instead of 'Call notfound'

Range("E3", Cells(Rows.Count, 5).End(xlUp)).SpecialCells(4) = "Not Found"

**amlan009** · 07-01-2012, 10:23 AM

You my friend ,is a pure genius !

This works like magic !

But the code is very difficult to understand for a newcomer like me ,but is a brilliant piece of work ,trust me ,what you have done using your code simply is beyond my mind to do manually ,

But i want to be in a through position to understand whats happening here ,

an you please explain what's happening here ,

.CompareMode = 1
    For i = 1 To UBound(x)
        If Not .Exists(x(i, 1)) Then
            .Item(x(i, 1)) = 1
            If Not Evaluate("ISREF('" & x(i, 1) & "'!A1)") Then
                Sheets.Add(after:=Sheets(Sheets.Count)).Name = x(i, 1)
            End If
        End If
    Next i: x = .keys
End With

what is the compare mode and what are the keys?

also what is this line doing ?

If Not Evaluate("ISREF('" & x(i, 1) & "'!A1)") Then

Find the input and output file attached !

This is just perfect ,

I also want to know whether you can increase the column width in the output file for all columns to 40 pixels or something which will help us see clearly all contents ,you will see that if the column width is less than the conetnt appears as ##### and we have to drag the column width ...can the macro handle to arrange the column width so as to make it visible ,

I will take a little assistance of yourself for understanding the code ,

P.S- I don't know how to use the alternative you gave in place of Call NOTFOUND ,i mean i am clueless as to where i should be putting it !

The entire code which i used for managing the input and output files is as follows ,

Option Explicit

Sub consolidateData()

        Const SHEET1_NAME = "Sheet1"
        Const SHEET2_NAME = "Sheet2"
        Const FINAL_SHEET_NAME = "Final"
        
        Dim final As Worksheet
        Dim lastCell As Range
        Dim i As Long, j As Long
        Dim dbc As Variant
        Dim shp As shape
        
        Application.ScreenUpdating = False
        On Error Resume Next
        Set final = Sheets(FINAL_SHEET_NAME)
        On Error GoTo 0
        If Not final Is Nothing Then
            Application.DisplayAlerts = False
            final.Delete
            Application.DisplayAlerts = True
        End If
        Sheets(SHEET1_NAME).Copy after:=Sheets(Sheets.Count)
        Set final = Sheets(Sheets.Count)
        final.Name = FINAL_SHEET_NAME
        With final
            .Range("F2").Value = "NATURE OF PYT"
            Set lastCell = .Cells(.Rows.Count, 1).End(xlUp)
            .Columns("G:H").Insert xlToLeft
            .Range("G2:H2").Value = Array("INVOICE NUMBER", "OUTSTANDING AMOUNT")
            .Range(lastCell(2, 1), .Cells.SpecialCells(xlCellTypeLastCell)).Clear
            For i = lastCell.Row To 3 Step -1
                With .Cells(i, "F")
                    If InStr(1, .Value, ",") > 0 Then
                        dbc = Split(.Value, ",")
                        .Offset(1).EntireRow.Insert
                        For j = 1 To UBound(dbc)
                            .EntireRow.Copy
                            .Offset(1).EntireRow.Insert xlDown
                            .Offset(1).Value = Trim(dbc(j))
                            .Offset(1).Font.Color = vbBlue
                            .Font.Size = 14
                            .Offset(1).Font.Size = 16
                        Next j
                        .Value = Trim(dbc(0))
                        .Font.Color = vbBlue
                        .Offset(UBound(dbc) + 1, 10).Formula = _
                                "=SUM(" & .Offset(0, 2).Resize(UBound(dbc) + 1).Address & ")"
                    Else
                        .Value = Trim(.Value)
                    End If
                End With
            Next i
            Application.CutCopyMode = False
            Set lastCell = .Cells(.Rows.Count, "F").End(xlUp)
            With .Range("G3", .Cells(lastCell.Row, "G"))
                .Formula = _
                        "=IFERROR(IF(F3="""","""",VLOOKUP(TEXT(F3,0)," & _
                        SHEET2_NAME & "!$A:$I,9,FALSE)),""NOT FOUND"")"
                .Value = .Value
            End With
            With .Range("H3", .Cells(lastCell.Row, "H"))
                .Formula = _
                        "=IFERROR(IF(F3="""",IF(P3="""","""",P3),VLOOKUP(TEXT(F3,0)," & _
                        SHEET2_NAME & "!$A:$I,6,FALSE)),""NOT FOUND"")"
                .Value = .Value
            End With
            With .Range("E3", .Cells(lastCell.Row, "E"))
                .Formula = "=TRIM(IFERROR(MID(G3,FIND(""^^"",SUBSTITUTE(G3,""/"",""^^""," & _
                        "LEN(G3)-LEN(SUBSTITUTE(G3,""/"",""""))))+1,LEN(G3)),""""))"
                .Value = .Value
                
            End With
            .Columns("F").Interior.ColorIndex = 0
            .Columns("P").ClearContents
            For Each shp In .Shapes
                If shp.Type = 8 Then
                    shp.Delete
                End If
            Next shp
        End With
        Application.ScreenUpdating = True
        Call Uppercase
        Call notfound
        Call nilemmagic
        
End Sub
Sub Uppercase()


Dim x As Variant
Dim LR As Long

 LR = Cells(Rows.Count, "E").End(xlUp).Row 'Last row number
      
      For x = LR To 3 Step -1
      'Loop to cycle through each cell in the specified range.
      
        Range("E" & x).Value = UCase(Range("E" & x).Value) 'Change the text in the range to uppercase letters.
     
     If Range("A" & x).Value = "" Then 'Check is value in A row empty
        Range("A" & x).EntireRow.Delete 'Delete entire row
        End If
    
        
     Next x
End Sub
        
        
Sub notfound()
        
        
Dim x As Variant
Dim LR As Long

 LR = Cells(Rows.Count, "E").End(xlUp).Row 'Last row number
      
      For x = LR To 3 Step -1
     
      'Loop to cycle through each cell in the specified range.
      
      If Range("E" & x).Value = "" Then 'Check whether Value in E is empty
        Range("E" & x).Value = "Not Found " 'Puts "Not Found in In it "
        End If
        
        Next x
        
        End Sub
        
        
        
Sub nilemmagic()
Dim x, i&: Application.ScreenUpdating = 0
With Sheets("Final")
    x = .Range("E3", .Cells(Rows.Count, 5).End(xlUp)).Value
End With

With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 1 To UBound(x)
        If Not .Exists(x(i, 1)) Then
            .Item(x(i, 1)) = 1
            If Not Evaluate("ISREF('" & x(i, 1) & "'!A1)") Then
                Sheets.Add(after:=Sheets(Sheets.Count)).Name = x(i, 1)
            End If
        End If
    Next i: x = .keys
End With

With Sheets("Final")
    With .Range("A2:O" & .Cells(Rows.Count, 1).End(xlUp).Row)
        .AutoFilter
        For i = 0 To UBound(x)
            .AutoFilter Field:=5, Criteria1:=x(i)
            .SpecialCells(12).Copy Sheets(x(i)).Range("A2")
'            Sheets(x(i)).Shapes(1).Delete
        Next i
        .AutoFilter
    End With
End With: Application.ScreenUpdating = 1
End Sub

Humble regards ,

Amlan Dutta

**nilem** · 07-01-2012, 01:53 PM

Originally Posted by amlan009

...I also want to know whether you can increase the column width in the output file for all columns ...

Try changing these lines

...
For i = 0 To UBound(x)
    .AutoFilter Field:=5, Criteria1:=x(i)
    .SpecialCells(12).Copy
    Sheets(x(i)).Range("A2").PasteSpecial Paste:=xlPasteColumnWidths
    Sheets(x(i)).Range("A2").PasteSpecial Paste:=xlPasteAll
Next i
...

Dictionary is an object that can contain only unique values of keys.
x = .keys is an array of dictionary keys, i.e. sheet names.
Expression of If Not Evaluate("ISREF('" & x(i, 1) & "'!A1)") Then examines whether there is a worksheet named x(i, 1).

You can write a line

Range("E3", Cells(Rows.Count, 5).End(xlUp)).SpecialCells(4) = "Not Found"

instead of a line

Call notfound

in your code.

**amlan009** · 07-02-2012, 09:40 PM

Hiya,

Sorry for the late revert ,i was studying the code and adding comments to understand the code ,at the end of each line ,i have added a comment wherein at times i understand completely what's going on but at times i am clueless because of advanced function's used ....if someone can comment on the parts ,i would be most grateful since it would help me understand the solution instead of just using it

Sub nilemmagic()
Dim x, i&: Application.ScreenUpdating = 0
With Sheets("Final") ' sees the tab "Final" in the workbook 
    x = .Range("E3", .Cells(Rows.Count, 5).End(xlUp)).Value  ' in the tab final ,it calculates last row in column E  starting from the 3rd Row ,i.e E3
End With

With CreateObject("Scripting.Dictionary") ' A library object is created 
    .CompareMode = 1 ' compare mode is turned on (need help what does this do ?)
    For i = 1 To UBound(x) 'basically looping through values for all values in used values of column E 
	'Need help ,am i correct in inferencing that by using Ubound(x) it means that all values (values in a array are referred to as keys )of x i.e Column E are 
	'now stored in a array and that that the loop goes from the first value (key ),i.e i= 1 or E3 to last
	'value of the array which may be E20000 or whatever be the last used value in Column E
	
        If Not .Exists(x(i, 1)) Then ' need help?what does x(i,1) mean ,what is 1 here and what is  . operator referencing to .
		 
            .Item(x(i, 1)) = 1    ' need help? what does this part do ?
            If Not Evaluate("ISREF('" & x(i, 1) & "'!A1)") Then 'what does !A1(not equal to A1) serve the code  
                Sheets.Add(after:=Sheets(Sheets.Count)).Name = x(i, 1) 'what does x(i,1) mean 
            End If
        End If
    Next i: x = .keys ' adds a key with the worksheet name 
End With

With Sheets("Final")
    With .Range("A2:O" & .Cells(Rows.Count, 1).End(xlUp).Row)'is checking range of used rows for complete range 
	 
        .AutoFilter ' need help what happens with autofilter command in this case ,what is being filtered and based on what criteria 

        For i = 0 To UBound(x)
            .AutoFilter Field:=5, Criteria1:=x(i) 'When we write Autofilter fiedd:=5 ,does it filter Column E ,I.e 5th column....

  .SpecialCells(12).Copy   'need help what does special cells(12) mean 
        Sheets(x(i)).Range("A2").PasteSpecial Paste:=xlPasteColumnWidths
        Sheets(x(i)).Range("A2").PasteSpecial Paste:=xlPasteAll'what is difference between paste column width ad paste all 
			
'            Sheets(x(i)).Shapes(1).Delete
        Next i
        .AutoFilter 'after loop ends ,what will autofilter do now 
    End With
End With: Application.ScreenUpdating = 1
End Sub

Thanks ,

Amlan Dutta