filter macros

Humar July 4, 2010 at 07:10:00

Hi, As you haven't provided any specific information on where your data is in the various workbooks, or path names, I can only offer a generic approach - you will have to change addresses etc. to match your requirements. This macro takes a list of filenames in Column A of the main workbook (your worksheet named 'list"). For each name it opens a workbook of the same name (followed by .xls - the macro adds the .xls). On opening each workbook it filters data in column A of Worksheet "Sheet1", filtered for 'non-blanks' It then copies the filtered cells The copied cells are then transposed (column to row) and pasted alongside the original filename. I suggest that you add the macro to a button on the worksheet containing the names. Create a command button from the Control Toolbox toolbar. (If this isn't visible, right click on an existing toolbar and check the Control Toolbox). Select the button Icon and draw a button Right-click the button and select Command Button - Edit and change the name to 'Get Data' or something suitable. Right-click the button again and select View Code In the code window that opens enter this: Option Explicit Private Sub CommandButton1_Click() Dim rngCell As Range Dim rngStart As Range Dim rngEnd As Range Dim strPath As String Dim strFilename As String Dim strFilePath As String Dim rngSourceEnd As Range 'set path name for all files - include closing "\" strPath = "C:\temp\" 'set start of list of names in Column A - heading on row 1 Set rngStart = Range("A2") 'find end of list of names in column A Set rngEnd = Range("A" & CStr(Application.Rows.Count)).End(xlUp) 'loop through names in list For Each rngCell In Range(rngStart, rngEnd) 'create filename strFilename = rngCell.Text & ".xls" 'create path/filename strFilePath = strPath & strFilename 'open the file Workbooks.Open Filename:=strFilePath With Workbooks(strFilename) With .Worksheets("Sheet1") 'filter on column A .Columns("A:A").AutoFilter Field:=1, Criteria1:="<>" 'find end of data in column A Set rngSourceEnd = .Range("A" & CStr(Application.Rows.Count)) _ .End(xlUp) 'copy data in column A .Range("A2:" & rngSourceEnd.Address) _ .SpecialCells(xlCellTypeVisible).Copy End With 'paste data (transpose) rngCell.Offset(0, 1).PasteSpecial xlPasteAll, Transpose:=True 'close file (dont save changes) .Close SaveChanges:=False End With Next rngCell End Sub Note that Private Sub CommandButton1_Click() and End sub will already be present, so don't duplicate them. Option Explicit goes before Private Sub CommandButton1_Click(). Some lines of code have been split onto two lines for ease of viewing, using the line continuation character "_". This should work 'as is' just copy and paste, or you could remove the "_" and bring the code back to one line. Click Save from the Visual Basic Menu. Alt+f11 takes you back to the main Excel window. Exit design mode (first icon on the Controls Toolbox toolbar). As changes made by Macros cannot be undone with the Undo button, test this macro on a copy of your data. Always make a backup of your Workbook before running this macro. This code has only been tested on sample data, and it has not been tested in your environment, so test it on copies of your data to ensure that it works 'as expected' Click the 'Get Data' button to run the macro Note that all the named workbooks are closed after filter/copy but changes are not saved. This is 'by design' so that the workbooks do not open with a filter already in place. Note also that re-running this macro will copy the changed/updated data - if there is less data than previous for any 'name' then the excess data will still be present on the relevant row. If you use this macro, after changing it to match your data etc. please post it as a response and a data clear up can be proposed. Regards

Hi, thank you so much for the timely help. this would really help in my task.. also i appreciate your comments in the coding...

I have a series of data from coulumn A to Q in sheet 1. and i need to filter some of the data and copy it to sheet 2 in the same workbook. i have given the manual steps which i would do , i need your help in automating these steps. The fist row in all columns has headings. first part. 1.Aplly auto filter to all. 2.filter "CREL" from coulmun C 3.filter blanks from column G 4.filter non blanks from column F 5.filter "CHANGE" from column K 6.now i need to copy the contents from column B,F and Q to sheet2 in column A,B,C. second part. 1.filter >show all. 2.filter "CREL" from coulmun C 3.filter non blanks from column G and then H 4.filter "CHANGE" from column P 5.now i need to copy the contents from column B,O and Q to sheet2 in column E,F,G. THIRD PART 1.filter >show all. 2.filter 'CREL' from coulmun C 3.filter blanks from column F 4.filter "CHANGE" from column P 5.now i need to copy the contents from column B,O and Q to sheet2 in column E,F,G i want append this to existing data from second part.

Also can u modify the code u gave me in the first instance, the change is in 'filter on column A .Columns("A:A").AutoFilter Field:=1, Criteria1:="<>" i need to go copy the data from the column whose heading says "SGID". ie, in the coressponding excel against each name in "list",i need to copy all the data in the column whose heading says "SGID", then paste in the same way as before.

Humar July 5, 2010 at 05:59:58

Hi, Here is a macro that does your "first part" Note that to copy the cells it has to find the last row containing data. The code searches in column A for this last row. If column A does not consistently contain data in all rows, either change the set end line to search another column, or hard code the row number, based on the last row ever used. I don't know your data, so I have no idea whether your data never exceeds a particular row or whether it is constantly expanding - so I can't be sure which is the best approach. 'find end of data in column A strRowEnd = CStr(.Range("A" & CStr(Application.Rows.Count)).End(xlUp).Row) For a fixed last row, say 50 use this: strRowEnd = "50" here is the macro: Option Explicit Private Sub CommandButton1_Click() With Worksheets("Sheet1") 'set start of data in column A strRowStart = "2" 'find end of data in column A strRowEnd = CStr(.Range("A" & CStr(Application.Rows.Count)) _ .End(xlUp).Row) 'select columns A to Q 'apply filter to cols C,F,G & K (cols.3,6,7 & 11) With .Columns("A:Q") .AutoFilter Field:=3, Criteria1:="CREL" .AutoFilter Field:=6, Criteria1:="<>" .AutoFilter Field:=7, Criteria1:="=" .AutoFilter Field:=11, Criteria1:="CHANGE" End With 'copy visible cells in columns B, F & Q Range("B" & strRowStart & ":B" & strRowEnd & "," & _ "F" & strRowStart & ":F" & strRowEnd & "," & _ "Q" & strRowStart & ":Q" & strRowEnd) _ .SpecialCells(xlCellTypeVisible).Copy 'and paste to Sheet2 starting at Cell A2 Worksheets("Sheet2").Range("A2").PasteSpecial _ Paste:=xlPasteValuesAndNumberFormats 'clear autofilter .Columns("A:Q").AutoFilter End With End Sub Note that I had this code attached to Button1, but as you may now have more than one button, the 'Sub' line will be different. If you select the button and use view code it will take you to the right place to paste it in. You should be able to modify this code to do your second part. The third part is slightly different as you want to append data, so you have to find where to start pasting the data. I will look at the third part tomorrow. Regards

hey thanks for ur help again, could you help me out in the response no.4. i have a job based on your macro tommorrow,it would be very nice of you, if you could do the changes for me in your code. I will be waiting for your help.. Thanks and Regards Ravana...

Humar July 5, 2010 at 12:40:06

Hi, Regarding response number 4 Do you want to filter based on the data in a column labeled "SGID" or do you want to filter on column A, but copy the filtered data from a column labeled "SGID" Is the column labeled "SGID" always the same column - because having to find the column based on "SGID" in row 1 requires extra code. Also are you copying the filtered data from column A and the column labeled "SGID". Regards

hi, i need to filter all, and "SGID" is not constant ,it keeps changing columns for each files. SO i need to search SGID first and filter nonblanks and copy it in the coressponding excel against each name in "list",

Humar July 6, 2010 at 04:01:23

Hi, Is the following correct: Open an Excel file based on name in column A of worksheet "list" (Name plus ".xls") In the named file that is opened, find a column with "SGID" in row 1 Autofilter the SGID row for all non-blank cells then select and copy the visible cells. Paste with a transpose (column to row), on the row with the same name. No other column in each opened (named) Excel file is used for a filter and no other column is copied/pasted. Regards

YA UR ABSOLUTEY RIGHT.

Hi, Also when searching SGID and IF IT Doesnt find anything means, the macro should proceed to the next name in the "list " file. Regards Ravana

Humar July 6, 2010 at 05:35:55

Hi, Here is a modified macro that opens the named files as before, but instead of filtering on Column A, it filters on a column with "SGID" on row 1. The filtered data is pasted as before. In addition, the macro removes existing data on each row before pasting new data. This ensures that if there is less new data than there was old data, some of the old data does not remain on the row. Screen updating has been turned off to remove screen flicker Change the path to your filies Option Explicit Private Sub CommandButton1_Click() Dim rngCell As Range Dim rngStart As Range Dim rngEnd As Range Dim strPath As String Dim strFilename As String Dim strFilePath As String Dim rngSourceEnd As Range Dim rngFind As Range On Error GoTo ErrHnd 'stop screen updating to remove flicker Application.ScreenUpdating = False 'set path name for all files - include closing "\" strPath = "C:\temp\" 'set start of list of names in Column A - heading on row 1 Set rngStart = Range("A2") 'find end of list of names in column A Set rngEnd = Range("A" & CStr(Application.Rows.Count)).End(xlUp) 'loop through names in list For Each rngCell In Range(rngStart, rngEnd) 'clean up any data on the row starting at column B 'put something in column B for End to find in case there was no data rngCell.Offset(0, 1).Value = "B" Range("B" & rngCell.Row, _ rngCell.Offset(0, CStr(Application.Columns.Count - 1)) _ .End(xlToLeft).Address) _ .Clear 'create filename strFilename = rngCell.Text & ".xls" 'create path/filename strFilePath = strPath & strFilename 'open the file Workbooks.Open Filename:=strFilePath With Workbooks(strFilename) With .Worksheets("Sheet1") 'find column with "SGID" in row 1 Set rngFind = .Rows(1).Find("SGID") 'find end of data in SGID column Set rngSourceEnd = rngFind.Offset(CStr(Application.Rows.Count) - 1, 0) _ .End(xlUp) 'filter on SGID column rngFind.EntireColumn.AutoFilter Field:=1, Criteria1:="<>" 'copy data in SGID column .Range(rngFind.Offset(1, 0).Address & ":" & rngSourceEnd.Address) _ .SpecialCells(xlCellTypeVisible).Copy End With 'paste data (transpose) rngCell.Offset(0, 1).PasteSpecial xlPasteAll, Transpose:=True 'remove filter rngFind.EntireColumn.AutoFilter 'close file (dont save changes) .Close SaveChanges:=False End With Next rngCell 'restore screen updating Application.ScreenUpdating = True Exit Sub 'error handler ErrHnd: Err.Clear 'restore screen updating Application.ScreenUpdating = True End Sub As before, I have only tested this on limited sample data. Test the macro on backup data and ensure that it works 'as expected' Always make a backup before running the macro. Regards EDIT: The above code was completed before seeing your additional requirement for files with no SGID column.

Humar July 6, 2010 at 06:20:28

Hi, This appears to work when you have files with no "SGID" heading on row 1 The code is not very elegant - adding to existing code like this is not good. Note that if a file previously had an SGID column, and now does not have an SGID row, the existing data will be removed from the row against that name. Option Explicit Private Sub CommandButton1_Click() Dim rngCell As Range Dim rngStart As Range Dim rngEnd As Range Dim strPath As String Dim strFilename As String Dim strFilePath As String Dim rngSourceEnd As Range Dim rngFind As Range On Error GoTo ErrHnd 'stop screen updating to remove flicker Application.ScreenUpdating = False 'set path name for all files - include closing "\" strPath = "C:\temp\" 'set start of list of names in Column A - heading on row 1 Set rngStart = Range("A2") 'find end of list of names in column A Set rngEnd = Range("A" & CStr(Application.Rows.Count)).End(xlUp) 'loop through names in list For Each rngCell In Range(rngStart, rngEnd) 'clean up any data on the row starting at column B 'put something in column B for End to find in case there was no data rngCell.Offset(0, 1).Value = "B" Range("B" & rngCell.Row, _ rngCell.Offset(0, CStr(Application.Columns.Count - 1)) _ .End(xlToLeft).Address) _ .Clear 'create filename strFilename = rngCell.Text & ".xls" 'create path/filename strFilePath = strPath & strFilename 'open the file Workbooks.Open Filename:=strFilePath With Workbooks(strFilename) With .Worksheets("Sheet1") 'find column with "SGID" in row 1 Set rngFind = .Rows(1).Find("SGID") 'only do this if "SGID" found If Not rngFind Is Nothing Then 'find end of data in SGID column Set rngSourceEnd = rngFind.Offset(CStr(Application.Rows.Count) - 1, 0) _ .End(xlUp) 'filter on SGID column rngFind.EntireColumn.AutoFilter Field:=1, Criteria1:="<>" 'copy data in SGID column .Range(rngFind.Offset(1, 0).Address & ":" & rngSourceEnd.Address) _ .SpecialCells(xlCellTypeVisible).Copy End If End With 'only do this if "SGID" found If Not rngFind Is Nothing Then 'paste data (transpose) rngCell.Offset(0, 1).PasteSpecial xlPasteAll, Transpose:=True 'remove filter rngFind.EntireColumn.AutoFilter End If 'close file (dont save changes) .Close SaveChanges:=False End With Next rngCell 'restore screen updating Application.ScreenUpdating = True Exit Sub 'error handler ErrHnd: Err.Clear 'restore screen updating Application.ScreenUpdating = True End Sub Regards

Hi, I appreciate you for spending time and resolving my quries, thanks a lot for your help, this would greatly reduce my work. Also learning from your works.. Thanks and Regards Ram

Humar July 6, 2010 at 20:03:36

Hi Ram, Thanks for your kind words. I am glad to hear that you have a solution ... which I am sure you will continue to build on. Regards Humar