Hi Priya,
I'm developping a website for an befriended artist. I've put her concerts and repertoire in two Excel files - easy for her to update - and added one single macro to them that runs several tasks in a row:
- sort the data
- search for duplicates
- rename the files with a date-code (YYMMDD) in the name, what helps for backing-up the data
- convert the data first into XML-format and then into an HTML-table that can be forwarded to people who might be interested in printing the data
- open an form in IE that uploads the files in XML and HTML-formats directly to the server of her website.
As far as I'm aware, I didn't encounter your type of problem.
For your info and hopefully your help, I add the lengthy code hereunder:
Option Explicit
Sub Sort_and_Eliminate_doubles_and_Send()
Dim OldFn, ShortFn As String, NewFn As String, FnRoot As String, DirDest As String, FN As String
Dim rownumber As Integer, colnumber As Integer, n As Integer
Dim MailAd As Variant, RRange As Variant
Dim fso As Object
Application.DisplayAlerts = False
Application.EnableEvents = False
Remplacer_symboles_par_caractères
Range("A1").Select Selection.End(xlDown).Select rownumber = ActiveCell.Row
Range("A1").Select
Selection.End(xlToRight).Select colnumber = ActiveCell.Column
Range(Cells(1, 1), Cells(rownumber, colnumber)).Sort _
Key1:=Range("A2"), Order1:=xlAscending, _
Key2:=Range("B2"), Order2:=xlAscending, _
Key3:=Range("C2"), Order3:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
n = 2
While Range("A" & n) <> ""
Range("A" & n).Select
If (LCase(Range("A" & n) & Range("B" & n) & Range("C" & n) & Range("D" & n) & Range("E" & n)) = LCase(Range("A" & n - 1) & Range("B" & n - 1) & Range("C" & n - 1) & Range("D" & n - 1) & Range("E" & n - 1))) Then
rownumber = ActiveCell.Row
RRange = "A" & rownumber & ""
Rows(rownumber & ":" & rownumber).Select
Selection.Delete Shift:=xlUp
Range(RRange).Select
MsgBox "Un double est à éliminer à la rangée " & rownumber & "."
End If
n = n + 1
Wend
OldFn = ActiveWorkbook.Name
FnRoot = Left(OldFn, Len(OldFn) - 11)
ShortFn = FnRoot & ".xls"
NewFn = FnRoot & "_" & Format(Date, "yymmdd") & ".xls"
If Application.UserName = "Erik" Then
DirDest = "D:\Web\Ulrike\"
MailAd = Array("ulrike.vancotthem@gmail.com")
End If
If Application.UserName <> "Erik" Then
DirDest = "C:\Documents and Settings\les amoureux\mes documents\mes kikis docs\mon site\tableau concerts\"
MailAd = Array("erik.vandyck@club-internet.fr")
End If
Application.EnableEvents = True
On Error Resume Next
MkDir DirDest & "Docs\"
FN = DirDest & "docs\" & NewFn
On Error Resume Next
ActiveWorkbook.SaveAs FileName:=FN, ReadOnlyRecommended:=False, AddToMru:=True
Application.DisplayAlerts = True
On Error Resume Next
Application.Dialogs(xlDialogSendMail).Show MailAd
FN = FnRoot & ".XML"
Make_XML DirDest, FN
FN = FnRoot & ".HTML"
Make_HTML DirDest, FN
MsgBox "Téléchargez en un coup" & Chr(10) & Chr(10) & """" & FnRoot & ".XML""" & " et" & Chr(10) & """" & FnRoot & ".HTML""" & Chr(10) & Chr(10) & "qui se trouvent tous les deux à """ & DirDest & """"
Open_IE DirDest, FN
If Application.UserName = "Erik" Then
Kill DirDest & "XML\" & FnRoot & ".XML"
Name DirDest & FnRoot & ".XML" As DirDest & "XML\" & FnRoot & ".XML"
Kill DirDest & "Docs\" & FnRoot & ".HTML"
Name DirDest & FnRoot & ".HTML" As DirDest & "Docs\" & FnRoot & ".HTML"
End If
End Sub
Sub Make_XML(Dir As String, FN As String)
ExportToXML Dir & FN, "Concert" End Sub
Public Function ExportToXML(FullPath As String, RowName _
As String) As Boolean
On Error GoTo ErrorHandler
Dim r As Integer, colIndex As Integer, rwIndex As Integer, iFileNum As Integer
Dim c As Variant
Dim sName As String Dim oWorkSheet As Worksheet
Dim lastCol As Long, lastRow As Long
Dim colList(7) As Integer
colList(0) = 6 colList(1) = 7 colList(2) = 8 colList(3) = 9 colList(4) = 12 colList(5) = 13 colList(6) = 14 colList(7) = 15
Set oWorkSheet = ThisWorkbook.Worksheets(1)
sName = oWorkSheet.Name
Range("A1").Select Selection.End(xlDown).Select lastRow = ActiveCell.Row
Range("A1").Select
Selection.End(xlToRight).Select lastCol = ActiveCell.Column
iFileNum = FreeFile
Open FullPath For Output As #iFileNum
Print #iFileNum, "<?xml version=""1.0"" encoding=""ISO-8859-1""?>"
Print #iFileNum, "<" & sName & " Date=""" & Format(Now, "dd/mm/yyyy hh:mm") & """>"
For r = 2 To lastRow
Print #iFileNum, "<" & RowName & ">"
For Each c In colList
Cells(r, c).Select
If c < 12 Then If Trim(Cells(r, c).Value) = "" Then
Cells(r, c).Value = " "
Else
Cells(r, c).Value = Trim(Cells(r, c).Value)
End If
End If
Select Case c
Case 13: Print #iFileNum, " <" & Cells(1, c).Value & ">" & Format(Cells(r, c).Value, "dd/mm/yy") & "</" & Cells(1, c).Value & ">" Case 14: Print #iFileNum, " <" & Cells(1, c).Value & ">" & Format(Cells(r, c).Value, "hh:mm") & "</" & Cells(1, c).Value & ">" Case Else: Print #iFileNum, " <" & Cells(1, c).Value & ">" & Cells(r, c).Value & "</" & Cells(1, c).Value & ">"
End Select
Next c
Print #iFileNum, "</" & RowName & ">"
Next r
Print #iFileNum, "</" & sName & ">"
ExportToXML = True
ErrorHandler:
If iFileNum > 0 Then Close #iFileNum
Exit Function
End Function
Sub Make_HTML(Dir As String, FN As String)
ExportToHTML Dir & FN
End Sub
Public Function ExportToHTML(FullPath As String) As Boolean
On Error GoTo ErrorHandler
Dim r As Integer, rr As Integer, lastRow As Integer, iFileNum As Integer, DateTimeTextCol As Integer
Dim toDay As String, firstConcert As String
Range("A1").Select Selection.End(xlDown).Select lastRow = ActiveCell.Row
DateTimeTextCol = 12
toDay = Format(Now, "yyyymmdd")
rr = 2
Do While Cells(rr, DateTimeTextCol).Value < toDay
Cells(rr, DateTimeTextCol).Select rr = rr + 1
Loop
firstConcert = Cells(rr, DateTimeTextCol).Value
iFileNum = FreeFile
Open FullPath For Output As #iFileNum
Print #iFileNum, "<!DOCTYPE html PUBLIC ""-//W3C//DTD XHTML 1.0 Strict//EN"" ""http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"">"
Print #iFileNum, "<html xmlns=""http://www.w3.org/1999/xhtml"">"
Print #iFileNum, "<head>"
Print #iFileNum, "<meta http-equiv=""Content-Type"" content=""text/html; charset=iso-8859-1"" />"
Print #iFileNum, "<title>Ulrike Van Cotthem: Prochains concerts prévus en date du " & Format(Now, "dd/mm/yyyy") & "</title>"
Print #iFileNum, "</head>"
Print #iFileNum, "<body>"
Print #iFileNum, "<table width=""100%"" border=""1"">"
Print #iFileNum, "<thead>"
Print #iFileNum, "<p style=""text-align:center;font-size:large;font-weight:bold"">Concerts chantés par Ulrike Van Cotthem entre " & Format(Cells(rr, DateTimeTextCol + 1).Value, "dd/mm/yyyy") & " et " & Format(Cells(lastRow, DateTimeTextCol + 1).Value, "dd/mm/yyyy") & "</p>"
Print #iFileNum, "</thead>"
Print #iFileNum, "<tr>"
Print #iFileNum, "<th scope=""col"">Date</th>"
Print #iFileNum, "<th scope=""col"">Heure</th>"
Print #iFileNum, "<th scope=""col"">Ville</th>"
Print #iFileNum, "<th scope=""col"">Lieu</th>"
Print #iFileNum, "<th scope=""col"">Programme</th>"
Print #iFileNum, "<th scope=""col"">Musiciens</th>"
Print #iFileNum, "</tr>"
For r = rr To lastRow
Cells(r, 13).Select Print #iFileNum, "<tr>"
Print #iFileNum, "<td>" & Cells(r, 13) & "</td>" Print #iFileNum, "<td>" & Format(Cells(r, 14), "hh:mm") & "</td>" Print #iFileNum, "<td>" & Cells(r, 6) & "</td>" Print #iFileNum, "<td>" & Cells(r, 7) & "</td>" Print #iFileNum, "<td>" & Cells(r, 8) & "</td>" Print #iFileNum, "<td>" & Cells(r, 9) & "</td>" Print #iFileNum, "</tr>"
Next r
Print #iFileNum, "</table>"
Print #iFileNum, "</body>"
Print #iFileNum, "</html>"
ExportToHTML = True
ErrorHandler:
If iFileNum > 0 Then Close #iFileNum
Exit Function
End Function
Sub Open_IE(Dir As String, FN As String)
Dim objFSO As Object
Dim IE, inp As Object
Set IE = CreateObject("InternetExplorer.application")
IE.Navigate "http://www.clermont-herault-concerts.fr/Ulrike_van_Cotthem_File_Upload_1.php"
IE.Visible = True
Do
DoEvents
Loop Until IE.ReadyState = 4
Set IE = Nothing
End Sub
|
General 
News 
Suggestion 
Question 
Bug 
Answer 
Joke 
Rant 
Admin