Macro to auto filter&save as html

Microsoft Office 2007 small business
June 15, 2010 at 11:42:57
Specs: Windows 7
Hi

I am new to this site and would like to send my greetings to all of you. I am new to macro and have never used em before, please help.

I need help on making a macro for the following situation. I receive a excel file that have more then 7000 names in cloumn B and i need to filter it to display only a certain name and then save as html format with the name that i just filtered and i have to create a main folder then a sub folder for every single saved file and on top of that i have to put it on the G: server drive.

I am sorry for my explanation, please bare with me. all this task is being done manually everyday and is taking much of my time.

So i would like to know if there is a way for me to have a macro that auto filter the list and save as htlm every filtered result and create the folders and sub foders with date stamps.

Any imput is tremendously appriciated, thank you all in advance.


See More: Macro to auto filter&save as html

Report •

#1
June 15, 2010 at 12:24:23
Hi,

A few questions for clarification:

1.
When you say more than 7000 names
Is that 7000 different names
or
7000 cells with names - but many are the same.

2.
If many are the same, approximately how many unique names are present in column B

3.
If there were say 100 unique names, can you confirm that you want 100 files saved, each in a unique sub-folder named with the appropriate 'filtered' name.

4.
If each file saved is filtered by a unique name, do you need to save only the data that belongs to that name.

5.
What row does the data start on. Is there is a header row or rows before the data.

6.
What is in column A - is it data that also needs to be saved.

Regards


Report •

#2
June 16, 2010 at 04:49:29
Hi
Thank you for your quick response here are the answer that you asked;
1.
When you say more than 7000 names
Is that 7000 different names
or
7000 cells with names - but many are the same.
***(1)- 7000 cells with names – but many are the same (and new names keeps adding to the list once a while)

2.
If many are the same, approximately how many unique names are present in column B
***(2)-good questions i’ve never counted them .

3.
If there were say 100 unique names, can you confirm that you want 100 files saved, each in a unique sub-folder named with the appropriate 'filtered' name.
***(3)- correct

4.
If each file saved is filtered by a unique name, do you need to save only the data that belongs to that name.
***(4)-yes

5.
What row does the data start on. Is there is a header row or rows before the data.
***(5)-the data always start at row 9, there is some tittle and row 8 is some filter bar wich i presently use to filter them and then save the data.

6.
What is in column A - is it data that also needs to be saved.
***(6)-there is nothing in column A

Again thank you for your help. You have no idea how your saving my life if this works. Tnx again.


Report •

#3
June 16, 2010 at 08:27:18
Hi,

I have created a macro which I think does all the steps you requested.

I have included comments in the macro to describe what each section does - lines starting with a ' are comments.

As this macro does quite a lot, I strongly suggest that you start with a copy of your workbook, and reduce the number of entries, just to test everything out.

The macro has a line that sets the base drive and folder.

It is set to C:\Temp\Test\
Change it to whatever suits - initially use a folder thats OK for testing and will not damage any existing data if it goes wrong!

The base path /folder must exist - the macro only makes the sub-folders using the names in column B

Remember that changes made by macros cannot be undone with the Undo button

The macro requires that the source workbook has the data in a worksheet names "Source"
(You could change all the occurrences of "Source" in the code to match your worksheet if you prefer)

The macro also requires a second worksheet in your source workbook named "Output"

The macro goes through the names in column B. It determines the last used row in column B by looking for the last cell with data in it in column B (on the worksheet named "Source") - so make sure there is no data below the last name.

The first name is set at Row 9, cell B9

Unique names are placed in an array and the macro has assumed that there will be no more unique names than the total divided by four, so if you have 8000 names, the macro allocates room for a maximum of 2000 unique names. This should be sufficient, but can be changed.

The data in the Source worksheet is then scanned for each name in turn and that name's data is copied to the Output worksheet. The data in the top 7 rows of the Source worksheet are also copied as headers, and the named data starts in row 8.

When all of that name's data has been transferred to the Output worksheet, the worksheet is copied to a new workbook which is named with the relevant name & html file type.

The new path is created for that name and a test is made to see if the folder with that name exists - if it doesn't, it is created under the base folder.
The new named workbook is saved. There is no warning about overwriting, so that when you run the macro again, it just creates new workbooks with the updated data.

To run the macro, I suggest you add a button to your source worksheet
From the Ribbon select Developer (If it's not visible go to the Office Button, select Excel options at the bottom and select the Popular tab and check the 'Show Developer tab in the Ribbon' box)

In Developer - Controls select Insert and choose the button icon.
Draw the button on the worksheet
In the 'Assign Macro' dialog box select 'New'

In the code window that opens enter this:

Option Explicit

Private Sub Button1_Click()
Dim strWkBkName As String
Dim rngStart As Range
Dim rngEnd As Range
Dim rngCell As Range
Dim rngDestStart As Range
Dim arryNames() As String
Dim intArry As Integer
Dim blnNotPresent As Boolean
Dim blnFound As Boolean
Dim intDestOffst As Integer
Dim wkbkNew As Workbook
Dim strPath As String
Dim strNamePath As String
Dim objFSO As Object
Dim n As Integer

On Error GoTo ErrHnd

'turn screen updating off to reduce flicker and increase speed
Application.ScreenUpdating = False

'save this workbook's name
strWkBkName = ActiveWorkbook.Name

'set start of source data
Set rngStart = ActiveSheet.Range("B9")
'find end of source data
Set rngEnd = ActiveSheet.Range("B" & CStr(Application.Rows.Count)).End(xlUp)

'set destination start
Set rngDestStart = Worksheets("Output").Range("A8")

'set Drive and Path to save files - including last "\"
strPath = "C:\temp\Test\"

'loop through the range and make an array of all unique names
'arbitrarily set array size as 25% of the number of rows
intArry = Int(rngEnd.Row / 4)
ReDim arryNames(intArry)

For Each rngCell In Range(rngStart, rngEnd)
    'reset flags
    blnFound = False
    blnNotPresent = False
    For n = 0 To intArry
        'flag if name found
        If rngCell.Text = arryNames(n) Then blnFound = True
        If blnFound = True Then Exit For
        'test if we have come to end of currently found names
        If arryNames(n) = "" Then blnNotPresent = True
        If blnNotPresent = True Then Exit For
    Next n
    'if name not present - save it
    If blnNotPresent = True Then
        arryNames(n) = rngCell.Text
    End If
Next rngCell

'use each unique name to create a data set in the "Output" worksheet
For n = 0 To intArry
    'only create a new worksheet if there is a name in the array
    If arryNames(n) <> "" Then
        'clear output worksheet
        Worksheets("Output").Cells.ClearContents
        'copy header rows 1 to 7 from Source to Output
        Worksheets("Source").Range("1:7").Copy _
                Destination:=Worksheets("Output").Range("A1")
        'set destination row offset counter
        intDestOffst = 0
        'get each set of source data that matches Name in array
        For Each rngCell In Range(rngStart, rngEnd)
            If rngCell.Text = arryNames(n) Then
                'copy row
                rngCell.EntireRow.Copy _
                    Destination:=rngDestStart.Offset(intDestOffst, 0)
                'increment offset counter
                intDestOffst = intDestOffst + 1
            End If
        Next rngCell
        
        'create the path (folder) for this 'name'
        strNamePath = strPath & arryNames(n) & "\"
        'create a file system object
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        'test if path already exists
        If objFSO.FolderExists(strNamePath) <> True Then
            'if not - create new folder here
            MkDir Path:=strNamePath
        End If
        
        'copy "Output" worksheet - this creates new workbook at same time
        Workbooks(strWkBkName).Worksheets("Output").Copy
        'save new workbook
        'turn off warnings so that SaveAs overwites existing file
        Application.DisplayAlerts = False
        Workbooks(Workbooks.Count).SaveAs _
                FileFormat:=xlHtml, _
                Filename:=strNamePath & arryNames(n) & ".html"
        'close new workbook
        Workbooks(Workbooks.Count).Close
        're-enable display alerts
        Application.DisplayAlerts = True
    End If
Next n

'turn screen updating on
Application.ScreenUpdating = True
Exit Sub

'error handler
ErrHnd:
Err.Clear
're-enable display alerts
Application.DisplayAlerts = True
'turn screen updating on
Application.ScreenUpdating = True
End Sub

Note that Sub Button1_Click() and End sub will already be present, so don't duplicate them. Option explicit goes before Sub Button1_Click().

Click SaveAs from the Visual Basic Menu and save in a Macro-enabled format.

Alt+f11 takes you back to the main Excel window.

Right click the button and Edit the name to something meaningful

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'

After selecting any cell, the new command button should now respond to a click and run the macro.

I hope that this does what you want - obviously it is a fairly complex macro, so if it doesn't work 'as expected' please post back with as much detail as possible.

The line to change the drive and base folder is:
'set Drive and Path to save files - including last "\"
strPath = "C:\temp\Test\"
You will need to change this to suit your environment before testing the macro.

Note that the macro turns the screen updating off, to reduce flicker and to increase speed. So don't expect to see much happening when it runs. In the taskbar you should see new Excel Workbooks appear and disappear.

The time it takes to run depends on the amount of data and the number of unique names, and will vary a lot depending on the drive - if it is a network drive it will likely be slower.

I tested this with about 1100 rows of data with 100 unique names and it took about 2 minutes to complete using an oldish laptop! (and a local drive).

Regards


Report •

Related Solutions

#4
June 16, 2010 at 08:48:53
OMG i thank you from the bottom of my heart my dear friend you are a life saver .. i will give this a try once i am done doing the manual labor of clicky .. and will let you know of the outcome. Again thank you for you expertise.

cheers!!


Report •

#5
June 16, 2010 at 10:09:07
Hi,

I would hold the 'cheers' until we get it to work!

Regards


Report •

#6
June 16, 2010 at 11:40:49
hi

Thank you so much again i have tested the macro and it does wonders.. you are such a genious.

now i do have a small request tho .. i tried to change
Filename:=strNamePath & arryNames(n) & ".xsl" to Filename:=strNamePath & arryNames(n) & ".htm"
and when i open the file its all gibrish ... please excuse for my nobbish .. macro programming .. but i think what i did is wrong :( .. i need to have the file save as html for publishing .. please help agani thank you.

sorry i forgot to ask also if it's possible when saving the new files to keep the cells formats (seize).

tnx


Report •

#7
June 16, 2010 at 13:32:59
Hi,

Sorry - my fault - I recognized after I posted the macro that you wanted html.

I edited the post, obviously after you copied the original code.

If you go to the code - right click the "Source" worksheet tab name and click View Code.

In the code replace the save line with this:

        Workbooks(Workbooks.Count).SaveAs _
                FileFormat:=xlHtml, _
                Filename:=strNamePath & arryNames(n) & ".html"

Regards


Report •

#8
June 16, 2010 at 13:58:49
Hi,

I looked at the formating.

If there is formatting in the Source worksheet, it is copied to the individual files. The default gridlines do not show in the html file, so the data must be explicitly formatted with borders.

If the formatting is still not sufficient it might be possible to add some formating before each file is saved.

Also once it's working we can add date-stamping.

Regards


Report •

#9
June 17, 2010 at 06:38:34
hi

i am galdy to tell you that it is working as i wanted, thank you very much.

In addition i would like to ask you a few things.
-when saving the file is there a was to keep the tables header in row 8
-and also keep the cells hight and weidth
-and i notice that in the new saved file, some has empty cells and some are limited and don't show all .. is there a way to only show what's been found in the filtering and of there is 3000 line per say .. to have them show all .. and if only 20 then the table won't show 200 empty rows?

other than that i am very grateful to your knowledge again thank you.

regards,


Report •

#10
June 17, 2010 at 07:21:15
Hi,

This line:

        Worksheets("Source").Range("1:7").Copy _
                Destination:=Worksheets("Output").Range("A1")

copies the first 7 rows on the Source worksheet and copies it to the Output worksheet. Change it to "1:8"

Then change this:

'set destination start
Set rngDestStart = Worksheets("Output").Range("A8")
to A9 so that data starts below the additional header row.

To maintain column widths we could add these lines after the header rows are copied:

        'copy column widths
        Worksheets("Source").Rows(1).Copy
        Worksheets("Output").Range("A1").PasteSpecial Paste:=xlPasteColumnWidths

To use the same row heights as original data add this after each row of data is copied:

                'copy row height
                rngDestStart.Offset(intDestOffst, 0).RowHeight = rngCell.RowHeight

Here is the revised code incorporating changes discussed above

Option Explicit

Private Sub CommandButton1_Click()
Dim strWkBkName As String
Dim rngStart As Range
Dim rngEnd As Range
Dim rngCell As Range
Dim rngDestStart As Range
Dim arryNames() As String
Dim intArry As Integer
Dim blnNotPresent As Boolean
Dim blnFound As Boolean
Dim intDestOffst As Integer
Dim wkbkNew As Workbook
Dim strPath As String
Dim strNamePath As String
Dim objFSO As Object
Dim n As Integer

On Error GoTo ErrHnd

'turn screen updating off to reduce flicker and increase speed
Application.ScreenUpdating = False

'save this workbook's name
strWkBkName = ActiveWorkbook.Name

'set start of source data
Set rngStart = ActiveSheet.Range("B9")
'find end of source data
Set rngEnd = ActiveSheet.Range("B" & CStr(Application.Rows.Count)).End(xlUp)

'set destination start
Set rngDestStart = Worksheets("Output").Range("A9")

'set Drive and Path to save files - including last "\"
strPath = "C:\temp\Test\"

'loop through the range and make an array of all unique names
'arbitrarily set array size as 25% of the number of rows
intArry = Int(rngEnd.Row / 4)
ReDim arryNames(intArry)

For Each rngCell In Range(rngStart, rngEnd)
    'reset flags
    blnFound = False
    blnNotPresent = False
    For n = 0 To intArry
        'flag if name found
        If rngCell.Text = arryNames(n) Then blnFound = True
        If blnFound = True Then Exit For
        'test if we have come to end of currently found names
        If arryNames(n) = "" Then blnNotPresent = True
        If blnNotPresent = True Then Exit For
    Next n
    'if name not present - save it
    If blnNotPresent = True Then
        arryNames(n) = rngCell.Text
    End If
Next rngCell

'use each unique name to create a data set in the "Output" worksheet
For n = 0 To intArry
    'only create a new worksheet if there is a name in the array
    If arryNames(n) <> "" Then
        'clear output worksheet
        Worksheets("Output").Cells.ClearContents
        'copy header rows 1 to 7 from Source to Output
        Worksheets("Source").Range("1:8").Copy _
                Destination:=Worksheets("Output").Range("A1")
        'copy column widths
        Worksheets("Source").Rows(1).Copy
        Worksheets("Output").Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
        'set destination row offset counter
        intDestOffst = 0
        'get each set of source data that matches Name in array
        For Each rngCell In Range(rngStart, rngEnd)
            If rngCell.Text = arryNames(n) Then
                'copy row data
                rngCell.EntireRow.Copy _
                    Destination:=rngDestStart.Offset(intDestOffst, 0)
                'copy row height
                rngDestStart.Offset(intDestOffst, 0).RowHeight = rngCell.RowHeight
                'increment offset counter
                intDestOffst = intDestOffst + 1
            End If
        Next rngCell
        
        'create the path (folder) for this 'name'
        strNamePath = strPath & arryNames(n) & "\"
        'create a file system object
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        'test if path already exists
        If objFSO.FolderExists(strNamePath) <> True Then
            'if not - create new folder here
            MkDir Path:=strNamePath
        End If
        
        'copy "Output" worksheet - this creates new workbook at same time
        Workbooks(strWkBkName).Worksheets("Output").Copy
        'save new workbook
        'turn off warnings so that SaveAs overwites existing file
        Application.DisplayAlerts = False
        Workbooks(Workbooks.Count).SaveAs _
                FileFormat:=xlHtml, _
                Filename:=strNamePath & arryNames(n) & ".html"
        'close new workbook
        Workbooks(Workbooks.Count).Close
        're-enable display alerts
        Application.DisplayAlerts = True
    End If
Next n

'turn screen updating on
Application.ScreenUpdating = True
Exit Sub

'error handler
ErrHnd:
Err.Clear
're-enable display alerts
Application.DisplayAlerts = True
'turn screen updating on
Application.ScreenUpdating = True
End Sub

Regards


Report •

#11
June 17, 2010 at 07:27:49
Hi,

Regarding i notice that in the new saved file, some has empty cells and some are limited and don't show all ..

Could you give more specific examples.

When I run the code on my sample data, I don't get any blank cells.
All the data for each name shows up in the Output file, with no spaces between - whether it's ten rows or 50.

Also could you give a bit more detail about the source data - are there any empty rows between data on the Source worksheet.

Regards


Report •

#12
June 17, 2010 at 07:48:54
hi

what i mean is some of the new saved file have like 150 rows but only 40 row contains data the rest is empty rows. Then again could be me lol .. let me try a couple more time with different source and i will update you.

Many thanks

cheers!!


edit: everything is great .. seems towork but i get a runtime error 76 at the end. and it point me to this line > MkDir Path:=strNamePath
dunno why..

but the folders are there and all


Report •

#13
June 18, 2010 at 04:45:11
Hi,

Please remove the single quote from:

'On Error GoTo ErrHnd

I quoted out the line for testing and forgot to reinstate it.

This will stop the error message, but it won't tell us why there was an error.

Please add this line before the last line (End Sub):

MsgBox "Name: " & arryNames(n) & vbCrLf & "Path: " & strNamePath

Let me know what appears when you run it again - hopefully the message will help identify why the MkDir line causes an error.

Regarding empty lines in some files, I suspect it is because some files are longer than others and formatting from the longer files still appears in the shorter files.

Replace this line:

Worksheets("Output").Cells.ClearContents
with this:
Worksheets("Output").Cells.Clear

and see if that helps.

Regards


Report •

#14
June 18, 2010 at 07:17:24
dear Friend .. you are awsome its working like butter .. loving it htank so much .. you just made my day..

I found out that the error was a problem in the naming in 1 of the cells... no big deal..

cheers!! to you...

say what if one day i wanted to do this;
you know how presently we have the filtered name in column B saved as a sub folder right..

so what if .. have the name in column B saved like the ways its is but the twist is within the filtered output do a filter of column C and have that list saved in the same way as column B.

so sorry dun even know if that makes sence lol ..

in other words, coloumn B master folder > column C subfolder

well let me try to give you an example lol .. in column B is a list of countries what need to be filered and saved as master folder then in column C is their provinces that needs to be seperated and saved as sub folder under their respective country.

in other word i can think of is a double filter then save as html !?!?!..

damn i am so confuse just trying to explain .. so sorry..

I hope you like challenges .. cuz this is so confusing to me lol

a\and again tnx much for all your help.

cheers


Report •

#15
June 18, 2010 at 10:07:31
Hi,

Thanks for the feedback - great to know that it works.

As to your new project - Yes it's possible!

However I am rather busy so it might be some time before I think about it in detail. If you have more detail or more ideas about how it should work, just post again.

As it is a new project it would be better in a new post.

Regards

Humar


Report •

#16
June 18, 2010 at 10:48:32
okay .. will do .. tnx again Humar.

Report •

#17
June 22, 2010 at 11:32:15
hi humar

I thank you again for your help, as you instructed i have create a new post for what I am looking to do, i have tried a few things on the macr myself please help when you have time here is the link
http://www.computing.net/answers/of...

again thank you

regards,


Report •

Ask Question