从给定文件夹打开多个HTML文件（报告）

时间：2014-03-09 20:39:37

标签： excel-vba vba excel

以下代码打开一个菜单，用于选择从中绘制所需html文件的文件夹。目前，这只选择所选文件夹中的第一个文件，而不选择其他文件。但是，我想修改它以选择给定文件夹中的所有html文件，并在单独的工作簿中打开每个文件。是否有一种简单的方法来修改此代码来执行此操作？我应该注意到，代码似乎确实在我打开第一个文件时给出了一个错误，我怀疑它与HTML有关，而excel的导入方法支持XML。任何帮助将不胜感激！

Sub ImportXMLData()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String
Dim xlWkBk As Workbook, xmlFile As Workbook, LastRow As Long
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.html", vbNormal)
Set xlWkBk = ThisWorkbook
While strFile <> ""
  LastRow = xlWkBk.Sheets(1).Cells.SpecialCells(xlCellTypeLastCell).Row + 1
  Set xmlFile = Workbooks.OpenXML(Filename:=strFolder & "\" & strFile)
  xmlFile.Sheets(1).UsedRange.Copy
  xlWkBk.Sheets(1).Cells(LastRow, 1).Paste
  xmlFile.Close SaveChanges:=False
  strFile = Dir()
Wend
Set xmlFile = Nothing: Set xlWkBk = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

我为冗长的代码道歉，但重新安排子的一些示例看起来像这样：

Sub Rearranging()
'
' Rearranging Macro
'

'
    Range("A1:J2").Select
    Range("A2").Activate
    Selection.ClearContents
    Range("A1:J1").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Selection.UnMerge
    Range("A3").Select
    Selection.Copy
    Range("A2").Select
    ActiveSheet.Paste
    Range("A3").Select
    Application.CutCopyMode = False
    Selection.ClearContents
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "date"
    Range("A7:B10").Select
    Selection.Copy
    Range("B1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Range("A13:B14").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("F1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Range("A22:B27").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("H1").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "amount approved"
    Range("I1").Select
    Range("A22:B27").Select
    Selection.Copy
    Range("J1").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = ""
    Range("J1").Select
    Range("A22:B27").Select
    Selection.Copy
    Range("J1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Range("A20").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("H2").Select
    ActiveSheet.Paste
    Columns("I:I").ColumnWidth = 16.14
    Range("P1").Select
    Range("A31:B31").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("P1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Range("A37:B37").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveWindow.SmallScroll Down:=-21
    Range("Q1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    ActiveWindow.SmallScroll Down:=18
    ActiveWindow.ScrollColumn = 1
    ActiveWindow.SmallScroll Down:=21
    Range("A45:B62").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveWindow.SmallScroll Down:=-45
    ActiveWindow.ScrollColumn = 2
    Range("R1").Select
    ActiveWindow.SmallScroll Down:=-6
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    ActiveWindow.SmallScroll Down:=63
    Range("A74:C77").Select
    Range("C77").Activate
    ActiveWindow.SmallScroll Down:=-3
    Range("A68:E82").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("AJ1").Select
    Range("A68:E68").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("AJ1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    ActiveSheet.Paste
    Range("AJ2:AN5").Select
    Application.CutCopyMode = False
    Selection.ClearContents
    Range("AJ1").Select
    ActiveCell.FormulaR1C1 = "[Index Date Member# Member Name]"
    Range("AK1:AN1").Select
    Selection.ClearContents
    Range("AJ2").Select
    ActiveCell.FormulaR1C1 = ""
    Range("D69:D82").Select
    Selection.Copy
    Range("A86:B87").Select
    Selection.Copy
    Range("AK1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Range("A95:G100").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveWindow.ScrollColumn = 17
    Range("AL2").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
End Sub

我删除了很多With语句以减少空间。我现在将以当前的形式测试你的代码！

1 个答案:

答案 0 :(得分：1)

以下代码打开单独工作簿中的每个文件，并将文件保存在同一文件夹中

经过测试 

Sub ImportXMLData()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim strFolder As String, strFile As String
Dim xlWkBk As Workbook, xmlFile As Workbook, LastRow As Long
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.html", vbNormal)
Set xlWkBk = ThisWorkbook
While strFile <> ""
  LastRow = xlWkBk.Sheets(1).Cells.SpecialCells(xlCellTypeLastCell).Row + 1
  Set xmlFile = Workbooks.OpenXML(Filename:=strFolder & "\" & strFile)
  xmlFile.Sheets(1).UsedRange.Copy
 Workbooks.Add
 ActiveSheet.Paste

call Rearranging ' This will calls sub for each file

  ActiveWorkbook.SaveAs strFolder & "\" & Replace(xmlFile.Name, ".html", ""), xlNormal
  xmlFile.Close SaveChanges:=False
  ActiveWorkbook.Close
  strFile = Dir()
Wend
Set xmlFile = Nothing: Set xlWkBk = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

如果您需要任何帮助，请告诉我

相关问题
最新问题