AW: htm-import makro ändern
17.03.2010 19:28:53
fcs
Hallo Marky,
Luschy's Tipp reicht nicht ganz. Zusätzlich muss noch das Löschen von Blatt 1 gelöscht werden.
Gruß
Franz
Option Explicit
'Erstellt unter Excel 2007, Windows Vista
'Datum 2009-10-26, modifiziert 2010-03-17
'Ersteller: fcs
Sub HTM_Dateien_laden()
Dim wbHtm As Workbook, wbNeu As Workbook
Dim strDir As String, strBlattname As String
Dim objFiles() As Object, lngRes As Long, lngC As Long
On Error GoTo Fehler
'Startverzeichnis für Ordner-Auswahl
strDir = ":\" 'ggf ANPASSEN !!!
'Verzeichnisauswahl starten
strDir = fncBrowseForFolder2(defaultPath:=strDir)
If strDir "" Then
'Dateien im Verzeichnis suchen
'lngRes ist die Anzahl der gefundenen Dateien
'in der Objekt-Variablen "objFiles" wird die Dateiliste zurückgegeben
lngRes = FileSearchINFO(Files:=objFiles, InitialPath:=strDir, FileName:="*.htm", _
SubFolders:=True)
If lngRes > 0 Then
Set wbNeu = ActiveWorkbook 'Arbeitsmappe in die HTM-Blätter eingefügt werden
'Dateienliste abarbeiten
Application.ScreenUpdating = False
For lngC = 0 To lngRes - 1
'htm-Datei öffnen
Set wbHtm = Workbooks.Open(FileName:=objFiles(lngC))
With wbHtm.Sheets(1)
'Blatt umbenennen - Sample Name als Blattname
strBlattname = Trim(Mid(.Range("A2"), Len("Sample Name: ") + 1))
CheckName:
'Prüfen, ob Blatt mit dem Namen schon in neuer Datei vorhanden
If fncCheckSheet(wbNeu, strBlattname) = True Then
Application.ScreenUpdating = True
strBlattname = InputBox("Blatt mit Name """ & strBlattname _
& """ wurde schon vorhanden!" & vbLf & vbLf _
& "Bitte Blattnamen ändern" & vbLf _
& "(Bei Abbrechen wird das Blatt nicht importiert!)", _
Title:="HTM importieren - Blatt umbenennen", _
Default:=strBlattname & "(1)")
If strBlattname = "" Then
Application.ScreenUpdating = False
GoTo NextHTM_Datei
Else
GoTo CheckName
End If
Application.ScreenUpdating = False
End If
.Name = strBlattname
'Blatt kopieren
.Copy after:=wbNeu.Sheets(wbNeu.Sheets.Count)
End With
'Fenster in Zelle A10 fixieren
ActiveSheet.Range("A10").Select
ActiveWindow.FreezePanes = True
NextHTM_Datei:
'htm-Datei wieder schließen
wbHtm.Close savechanges:=False
Set wbHtm = Nothing
Next
'leeres 1. Blatt in neuer Datei löschen
Application.DisplayAlerts = False
Application.DisplayAlerts = True
Else
MsgBox "Keine HTM-Dateien gefunden!"
End If
End If
Fehler:
With Err
If .Number 0 Then
Select Case .Number
Case 999
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
If Not wbHtm Is Nothing Then wbHtm.Close savechanges:=False
End Select
End If
End With
ReDim objFiles(0 To 0)
Application.ScreenUpdating = True
End Sub
Function fncCheckSheet(wb As Workbook, strBlatt As String) As Boolean
'Prüft ob Blatt in Arbeitsmappe vorhanden
Dim objSheet As Object
For Each objSheet In wb.Worksheets
If LCase(objSheet.Name) = LCase(strBlatt) Then
fncCheckSheet = True
Exit For
End If
Next
End Function