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()
' This macro is written by Erik van Dyck
'
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
' Hide screen
Application.DisplayAlerts = False
' Stop "EnableEvents" while making automatic changes
Application.EnableEvents = False
Remplacer_symboles_par_caractères 'remplace "Œ" par "OE", "..." par "etc.", "œ" par "oe"
' Sort
Range("A1").Select 'Select top left corner
Selection.End(xlDown).Select 'Search bottom row
rownumber = ActiveCell.Row 'Remember bottom row
'MsgBox "Bottom row = " & rownumber
Range("A1").Select
Selection.End(xlToRight).Select 'Search most right column
colnumber = ActiveCell.Column
'MsgBox "Most right column = " & colnumber
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
' Identify doubles
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
' Copy without date in name to "My Data Sources"
OldFn = ActiveWorkbook.Name
FnRoot = Left(OldFn, Len(OldFn) - 11)
ShortFn = FnRoot & ".xls"
NewFn = FnRoot & "_" & Format(Date, "yymmdd") & ".xls" ': MsgBox "L'ancien fichier s'appelait " & OldFn & ", la racine en est " & ShortFn & " et le nouveau fichier s'appellera " & NewFn
' MsgBox "Votre ordinateur s'appelle " & """" & Application.UserName & """."
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\"
' DirDest = "C:\"
MailAd = Array("erik.vandyck@club-internet.fr")
End If
' Re-enable "EnableEvents" after the automatic actions above
Application.EnableEvents = True
' Save updates XLS-file
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
' Send file by email
On Error Resume Next
Application.Dialogs(xlDialogSendMail).Show MailAd
FN = FnRoot & ".XML"
Make_XML DirDest, FN
FN = FnRoot & ".HTML"
Make_HTML DirDest, FN
' Prepare uploading
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 'for uploading of XML- and HTML-file
' Move files to appropriate directories
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
' Application.Quit
End Sub
Sub Make_XML(Dir As String, FN As String)
'
' Make XML Macro
' Macro enregistrée le 04/04/2010 par Erik
'
ExportToXML Dir & FN, "Concert" '=name of top level node in XML-file
'
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 ', asCols() As String
Dim oWorkSheet As Worksheet
Dim lastCol As Long, lastRow As Long
Dim colList(7) As Integer
colList(0) = 6 ' 6 = ville
colList(1) = 7 ' 7 = lieu
colList(2) = 8 ' 8 = prog
colList(3) = 9 ' 9 = mus
colList(4) = 12 '12 = DateTimeText
colList(5) = 13 '13 = DateText
colList(6) = 14 '14 = HeureText
colList(7) = 15 '15 = DateTimeTextPeremption
Set oWorkSheet = ThisWorkbook.Worksheets(1)
sName = oWorkSheet.Name
Range("A1").Select 'Select top left corner
Selection.End(xlDown).Select 'Search bottom row
lastRow = ActiveCell.Row ':MsgBox "Bottom row = " & lastRow 'Remember bottom row
Range("A1").Select
Selection.End(xlToRight).Select 'Search most right column
lastCol = ActiveCell.Column ':MsgBox "Most right column = " & lastCol
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 'protège les colonnes calculées par des formules formatées
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 & ">" 'en format de date normalisé
Case 14: Print #iFileNum, " <" & Cells(1, c).Value & ">" & Format(Cells(r, c).Value, "hh:mm") & "</" & Cells(1, c).Value & ">" 'en format de temps normalisé Case Else: Print #iFileNum, " <" & asCols(c - 1) & ">" & Cells(r, c).Value & "</" & asCols(c - 1) & ">" 'en format texte inchangé
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)
'
' Make HTML Macro
'
ExportToHTML Dir & FN
'
End Sub
Public Function ExportToHTML(FullPath As String) As Boolean
'PURPOSE: EXPORTS AN EXCEL SPREADSHEET TO HTML
'PARAMETERS: FullPath: Full Path of File to Export Sheet
'RETURNS: True if Successful, false otherwise
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 'Select top left corner
Selection.End(xlDown).Select 'Search bottom row
lastRow = ActiveCell.Row ':MsgBox "Bottomrow = " & lastRow 'Remember bottom row
DateTimeTextCol = 12
toDay = Format(Now, "yyyymmdd") ':MsgBox "toDay = " & toDay
'Seek first future concert
rr = 2
Do While Cells(rr, DateTimeTextCol).Value < toDay
Cells(rr, DateTimeTextCol).Select 'Select top left corner
rr = rr + 1
Loop
firstConcert = Cells(rr, DateTimeTextCol).Value ':MsgBox "firstConcert = " & firstConcert
iFileNum = FreeFile
Open FullPath For Output As #iFileNum
Print #iFileNum, "<!DOCTYPE html PUBLIC ""-
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 'visual tracer
Print #iFileNum, "<tr>"
Print #iFileNum, "<td>" & Cells(r, 13) & "</td>" 'date
Print #iFileNum, "<td>" & Format(Cells(r, 14), "hh:mm") & "</td>" 'heure
Print #iFileNum, "<td>" & Cells(r, 6) & "</td>" 'ville
Print #iFileNum, "<td>" & Cells(r, 7) & "</td>" 'lieu
Print #iFileNum, "<td>" & Cells(r, 8) & "</td>" 'programme
Print #iFileNum, "<td>" & Cells(r, 9) & "</td>" 'musiciens
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)
'
' Open_IE Macro
'
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 
Praise 
Rant 
Admin 
Submit an article or tip
