PDA

View Full Version : [SOLVED:] Using array and column data to creat new sheets


mperrah
05-22-2012, 03:17 PM
I have data in first sheet "Data" trying to combine 3 columns of values with data from array and create a new worksheet with results. Have searched and tried to combine several concepts.
Any help is very much appreciated. I have hand coded the results off what I am working towards. But since the data values change often and Im trying to automate the process. Thanks again for all input.

Mark


Sub ConvertDataToHTMLSheet()
Dim WebWks As Worksheet
Dim SrcWks As Worksheet
Dim ws As Worksheet
Dim newSheetName As String
Dim myRng As Range
Dim myCell As Range
Dim iCtr As Long
Dim myWebHead As Variant
Dim myWebTable As Variant
Dim myWebFoot As Variant
Dim whName As Variant
Set WebWks = Worksheets("HTML")
Set SrcWks = Worksheets("Data")
With Application
.Calculate
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
whName = Array("400 Warehouse", "500 Warehouse", "Reliance Warehouse", "Shop")
myWebHead = Array("<html>", "<head>", "<title>", whName(i), "</title>", "</head>", "<body>", "<H1>", whName(i), "</H1>", "<table>")
myWebTable = Array("<tr>", "<td>", "<a href=""", Path(iCtr), """ alt=""", LinkName(iCtr), """>", LinkName(iCtr), "</a>", "</td>", "</tr>")
myWebFoot = Array("</table>", "</body>", "</html>")
With SrcWks
Set myRng = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
End With
For Each myCell In myRng.Cells
With myCell
If IsEmpty Then
ElseIf myCell.Value = "400 Warehouse" Then
Worksheets.Add().Name = "400 Warehouse"
Worksheet("400 Warehouse").Range("A1").value = myWebHead(0 to 10)
For iCtr = LBound(myRng) To UBound(myRng)
Worksheet("400 Warehouse").Range("A & (myCtr)).value = myWebTable(0 to 10)
Worksheet("400 Warehouse").Range("A & xlDown).value = myWebFoot(0 to 2)
ElseIf myCell.Value = "500 Warehouse" Then
Worksheets.Add().Name = "500 Warehouse"
Worksheet("500 Warehouse .Range("A1").value = myWebHead(0 to 10)
For iCtr = LBound(myRng) To UBound(myRng)
Worksheet("500 Warehouse.Range("A(myCtr)).value = myWebTable(0 to 10)
Worksheet("500 Warehouse.Range("A & xlDown).value = myWebFoot(0 to 2)
End With
End If
End With
Next myCell
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
mohanvijay
05-23-2012, 05:20 AM
Try This


Sub ConvertDataToHTMLSheet()
Dim WS_Data As Worksheet
Dim L_Row As Long
Dim T_Rng As Range
Dim T_Str As String
Dim i As Long
Dim ii As Integer
Dim Hld_Sh() As String
Set WS_Data = ThisWorkbook.Worksheets("Data")
Application.ScreenUpdating = False
With WS_Data
If .FilterMode = True Then .ShowAllData
L_Row = .Cells(Rows.Count, 1).End(xlUp).Row
.Range("a1:a" & L_Row).Copy .Range("f1")
.Range("f1:f" & L_Row).AdvancedFilter xlFilterInPlace, , , True
For Each T_Rng In .Range("f2:f" & L_Row).SpecialCells(xlCellTypeVisible)
T_Str = T_Str & T_Rng.Value & ";;"
Next
T_Str = Left(T_Str, Len(T_Str) - 2)
Set T_Rng = Nothing
.ShowAllData
Range("f1").EntireColumn.Delete
Hld_Sh = Split(T_Str, ";;")
Dim T_WS As Worksheet
On Error Resume Next
Application.DisplayAlerts = False
For ii = 0 To UBound(Hld_Sh)
Set T_WS = ThisWorkbook.Worksheets(Hld_Sh(ii))
If Not T_WS Is Nothing Then T_WS.Delete
Set T_WS = ThisWorkbook.Worksheets.Add
T_WS.Name = Hld_Sh(ii)
Set T_WS = Nothing
Next ii
On Error GoTo 0
Application.DisplayAlerts = True
For ii = 0 To UBound(Hld_Sh)
ThisWorkbook.Worksheets(Hld_Sh(ii)).Range("a1:g1").Value = _
Array("<html>", "<head>", "<title>" & Hld_Sh(ii) & " MSDS</title>", "</head>", _
"<body>", "<h1>" & Hld_Sh(ii) & " MSDS</h1>", "<table>")
ThisWorkbook.Worksheets(Hld_Sh(ii)).Range("a1:g1").Copy
ThisWorkbook.Worksheets(Hld_Sh(ii)).Range("a2").PasteSpecial Transpose:=True
Application.CutCopyMode = False
ThisWorkbook.Worksheets(Hld_Sh(ii)).Range("a1").EntireRow.Delete
Next ii
Dim P_Res As String
Dim P_WsName
Dim S_LRW As Long
Dim Cr_1 As String
Dim Cr_2 As String
For i = 2 To L_Row
Cr_2 = .Range("c" & i).Value
Cr_2 = Right(Cr_2, Len(Cr_2) - InStrRev(Cr_2, "\"))
Cr_1 = .Range("b" & i).Value
T_Str = .Range("a" & i).Value
P_Res = "<tr><td><a href=""" & T_Str & "\"
P_Res = P_Res & Cr_1 & "\" & Cr_2 & """ alt="""
P_Res = P_Res & Cr_1 & """>" & Cr_1 & "</a></td</tr>"
S_LRW = ThisWorkbook.Worksheets(T_Str).Cells(Rows.Count, 1).End(xlUp).Row + 1
ThisWorkbook.Worksheets(T_Str).Cells(S_LRW, 1).Value = P_Res
Next i
For ii = 0 To UBound(Hld_Sh)
T_Str = Hld_Sh(ii)
S_LRW = ThisWorkbook.Worksheets(T_Str).Cells(Rows.Count, 1).End(xlUp).Row + 1
ThisWorkbook.Worksheets(T_Str).Range("a" & S_LRW).Value = "</table>"
ThisWorkbook.Worksheets(T_Str).Range("a" & S_LRW + 1).Value = "</body>"
ThisWorkbook.Worksheets(T_Str).Range("a" & S_LRW + 2).Value = "</html>"
Next ii
End With
Set WS_Data = Nothing
Application.ScreenUpdating = True
End Sub
mperrah
05-23-2012, 08:22 AM
Wow, This is awesome! Thank you soo much.
I had one glitch where it was showing all data, but I commented the line out and it worked great.


Sub ConvertDataToHTMLSheet()
Dim WS_Data As Worksheet
Dim L_Row As Long
Dim T_Rng As Range
Dim T_Str As String
Dim i As Long
Dim ii As Integer
Dim Hld_Sh() As String
Set WS_Data = ThisWorkbook.Worksheets("Data")
Application.ScreenUpdating = False
With WS_Data
If .FilterMode = True Then .ShowAllData
L_Row = .Cells(Rows.Count, 1).End(xlUp).Row
.Range("a1:a" & L_Row).Copy .Range("f1")
.Range("f1:f" & L_Row).AdvancedFilter xlFilterInPlace, , , True
For Each T_Rng In .Range("f2:f" & L_Row).SpecialCells(xlCellTypeVisible)
T_Str = T_Str & T_Rng.Value & ";;"
Next
T_Str = Left(T_Str, Len(T_Str) - 2)
Set T_Rng = Nothing
' .ShowAllData <<<this is what throws an error, if I comment it out, just leaves the data sheet filtered - not a big deal. The hard work you rocked on!!
Range("f1").EntireColumn.Delete
Hld_Sh = Split(T_Str, ";;")
Dim T_WS As Worksheet
On Error Resume Next
Application.DisplayAlerts = False
mperrah
05-23-2012, 03:40 PM
thank you