Macro to auto filter&save as html

Microsoft Office 2007 small business
June 22, 2010 at 09:39:57
Specs: Windows 7
Thank to Humar for his hard work and knowledge he came up with the following macro for me:
Option Explicit

Sub Parser()
'Parsing by region


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

Application.ScreenUpdating = False


strWkBkName = ActiveWorkbook.Name

Set rngStart = ActiveSheet.Range("B9")
Set rngEnd = ActiveSheet.Range("B" & CStr(Application.Rows.Count)).End(xlUp)

Set rngDestStart = Worksheets("Sheet2").Range("A9")

strPath = "C:\Users\Documents\test\"

intArry = Int(rngEnd.Row / 4)
ReDim arryNames(intArry)

For Each rngCell In Range(rngStart, rngEnd)
blnFound = False
blnNotPresent = False
For n = 0 To intArry
If rngCell.Text = arryNames(n) Then blnFound = True
If blnFound = True Then Exit For
If arryNames(n) = "" Then blnNotPresent = True
If blnNotPresent = True Then Exit For
Next n
If blnNotPresent = True Then
arryNames(n) = rngCell.Text
End If
Next rngCell

For n = 0 To intArry
If arryNames(n) <> "" Then
Worksheets("Sheet2").Cells.Clear
Worksheets("Sheet1").Range("1:8").Copy _
Destination:=Worksheets("Sheet2").Range("A1")
Worksheets("Sheet1").Rows(1).Copy
Worksheets("Sheet2").Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
intDestOffst = 0
For Each rngCell In Range(rngStart, rngEnd)
If rngCell.Text = arryNames(n) Then
rngCell.EntireRow.Copy _
Destination:=rngDestStart.Offset(intDestOffst, 0)
rngDestStart.Offset(intDestOffst, 0).RowHeight = rngCell.RowHeight
intDestOffst = intDestOffst + 1
End If
Next rngCell

strNamePath = strPath & arryNames(n) & "\"
Set objFSO = CreateObject("Scripting.FileSystemObject")
If objFSO.FolderExists(strNamePath) <> True Then
MkDir Path:=strNamePath
End If

Workbooks(strWkBkName).Worksheets("Sheet2").Copy
Application.DisplayAlerts = False
Workbooks(Workbooks.Count).SaveAs _
FileFormat:=xlHtml, _
Filename:=strNamePath & arryNames(n) & ".html"
Workbooks(Workbooks.Count).Close
Application.DisplayAlerts = True
End If
Next n

Application.ScreenUpdating = True
Exit Sub

ErrHnd:
Err.Clear
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Name: " & arryNames(n) & vbCrLf & "Path: " & strNamePath
End Sub

works great and its awsome, it really made my life simpler. Humar where ever you are thank you.

For me all this macro stuff is still so confusing, i tried a few things and well i messed up.

here is what i want to do.

COLUMN B COLUMN C
test1 b
test a
test b
test1 a
test b
test1 a
test b
test a
test1 b

as you can see in the macro that Humar created all the html files are created and saved in a seperate folder with the name in column b, what i want to do is have the column b as the main folder and continue the filtering with column c and then save those as sub-folder with the html file.

so all the same name in column b are in their respective folder and inside the folder are the filtered html files in a folder with the name as folder name.

So should be something like this;

folder "test">folder"a" with the html inside / folder "b" with htlm file inside.

i am sorry if i can't explain this properly.. this macro thing as you can see is still so confusing to me.

I thank you in advance for you help and knowledge.

regards,


See More: Macro to auto filter&save as html

Report •

#1
June 22, 2010 at 11:25:57
Hi

for what its worth please don't flame my nobness here is what i have tried .. i was able to filter the column c and save it as folders and html file .. my problem is the main filtering of colum B and saving them as main folder here is my code:

Option Explicit

Sub neeew1()
'Parsing by region


Dim strWkBkName As String
Dim rngStart As Range
Dim rngEnd As Range
Dim rng1Start As Range
Dim rng1End As Range
Dim rngCell As Range
Dim rng1Cell 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

Application.ScreenUpdating = False


strWkBkName = ActiveWorkbook.Name

Set rngStart = ActiveSheet.Range("B9")
Set rngEnd = ActiveSheet.Range("B" & CStr(Application.Rows.Count)).End(xlUp)

Set rng1Start = ActiveSheet.Range("C9")
Set rng1End = ActiveSheet.Range("C" & CStr(Application.Rows.Count)).End(xlUp)

Set rngDestStart = Worksheets("Sheet2").Range("A9")

strPath = "C:\Users\bdo\Documents\S-report\region test\test\"

intArry = Int(rng1End.Row / 4)
ReDim arryNames(intArry)

For Each rngCell In Range(rng1Start, rng1End)
blnFound = False
blnNotPresent = False
For n = 0 To intArry
If rngCell.Text = arryNames(n) Then blnFound = True
If blnFound = True Then Exit For
If arryNames(n) = "" Then blnNotPresent = True
If blnNotPresent = True Then Exit For
Next n
If blnNotPresent = True Then
arryNames(n) = rngCell.Text
----------------------------------------------------------------------------------------- this is my problem i think...
-----------------------------------------------------------------------------------------
For Each rngCell In Range(rngStart, rngEnd)
blnFound = False
blnNotPresent = False
For m = 0 To intArry
If rngCell.Text = arryNames(m) Then blnFound = True
If blnFound = True Then Exit For
If arryNames(m) = "" Then blnNotPresent = True
If blnNotPresent = True Then Exit For
Next m
If blnNotPresent = True Then
arryNames(m) = rngCell.Text
End If
-----------------------------------------------------------------------------------------
Next rngCell

For n = 0 To intArry
If arryNames(n) <> "" Then
Worksheets("Sheet2").Cells.Clear
Worksheets("Sheet1").Range("1:8").Copy _
Destination:=Worksheets("Sheet2").Range("A1")
Worksheets("Sheet1").Rows(1).Copy
Worksheets("Sheet2").Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
intDestOffst = 0
For Each rngCell In Range(rng1Start, rng1End)
If rngCell.Text = arryNames(n) Then
rngCell.EntireRow.Copy _
Destination:=rngDestStart.Offset(intDestOffst, 0)
rngDestStart.Offset(intDestOffst, 0).RowHeight = rngCell.RowHeight
intDestOffst = intDestOffst + 1

End If
Next rngCell

strNamePath = strPath & arryName(m) & "\" & arryNames(n) & "\"

Set objFSO = CreateObject("Scripting.FileSystemObject")
If objFSO.FolderExists(strNamePath) <> True Then
MkDir Path:=strNamePath
End If

Workbooks(strWkBkName).Worksheets("Sheet2").Copy
Application.DisplayAlerts = False
Workbooks(Workbooks.Count).SaveAs _
FileFormat:=xlHtml, _
Filename:=strNamePath & arryNames(n) & ".html"
Workbooks(Workbooks.Count).Close
Application.DisplayAlerts = True
End If
Next n

Application.ScreenUpdating = True
Exit Sub

ErrHnd:
Err.Clear
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Name: " & arryNames(n) & vbCrLf & "Path: " & strNamePath
End Sub


Thank you in advance.. :)


Report •
Related Solutions


Ask Question