0

我有一组 Excel 电子表格要总结。我的床单编号：xxx-yy-zzzz；xxx-yy-zzz+1；等等

我想要一个报告电子表格以在每次打开时检索信息。我不介意用 VBA 或公式来做。

我有下面的宏。我需要自动递增，直到用完电子表格。所有文件将在同一个文件夹中，该文件可以在任何文件夹中。

Sub Macro1()

'
' Macro1 Macro
' autopop
'
'
    Range("C4").Select
    ActiveCell.FormulaR1C1 = "='[413-05-001.xlsx]Cover'!R4C5"
    Range("D4").Select
    ActiveCell.FormulaR1C1 = "='[413-05-001.xlsx]Cover'!R5C3"
    Range("E4").Select
    ActiveCell.FormulaR1C1 = "='[413-05-001.xlsx]Order'!R27C9"
    Range("F4").Select
    ActiveCell.FormulaR1C1 = "='[413-05-001.xlsx]Cover'!R8C9"

End Sub
4

2 回答 2

1

当我们使用非常简单的文件名时，上述 Siddharth 的方法非常有效，但是当文件名添加了内容时，它变得更加困难......所以我做了一些冲浪并找到了“列出所有文件并放置它们在工作表中”并使用上面 Siddharth 回答中的一些代码（非常感谢 Siddharth 先生）和我在此处在线找到的示例http://alanmurray.blogspot.com/2013/08/excel-vba-list -all-excel-files-in-folder.html，我已经完成了我的代码，我的小 VBA 应用程序现在可以做我想做的事了——它打开一个文件夹并遍历并拉出特定的单元格并在几秒钟内创建一个摘要报告—— > 将节省我数小时的繁琐工作...

代码：

Sub ImportFileList()
Dim MyFolder As String 'Store the folder selected by the using
Dim FiletoList As String 'store the name of the file ready for listing
Dim NextRow As Long 'Store the row to write the filename to

On Error Resume Next

Application.ScreenUpdating = False

'Display the folder picker dialog box for user selection of directory
With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Please select a folder"
    .Show
    .AllowMultiSelect = False

    If .SelectedItems.Count = 0 Then
        MsgBox "You did not select a folder"
        Exit Sub
    End If
    MyFolder = .SelectedItems(1) & "\"
End With

'Dir finds the first Excel workbook in the folder
FiletoList = Dir(MyFolder & "*.xls")
Range("A1").Value = "Filename"
Range("B1").Value = "Purchase Order Number" 
Range("C1").Value = "Vendor"
Range("D1").Value = "Date of PO"
Range("E1").Value = "Currency"
Range("F1").Value = "Subtotal"
Range("G1").Value = "VAT"
Range("H1").Value = "Total"
Range("A1:H1").Font.Bold = True

'Find the next empty row in the list
NextRow = Application.CountA(Range("A:A")) + 1 
NextRow = NextRow + 1 ' skip a line

'Do whilst the dir function returns an Excel workbook
Do While FiletoList <> ""
    Cells(NextRow, 1).Value = FiletoList 'Write the filename into the next available cell
    Cells(NextRow, 2).Formula = "='[" & FiletoList & "]Cover'!R4C4" ' Cover is the excel sheet name
    Cells(NextRow, 3).Formula = "='[" & FiletoList & "]Cover'!R6C3"
    Cells(NextRow, 4).Formula = "='[" & FiletoList & "]Cover'!R4C7"
    Cells(NextRow, 5).Formula = "='[" & FiletoList & "]Cover'!R21C4"
    Cells(NextRow, 6).Formula = "='[" & FiletoList & "]Cover'!R19C5"
    Cells(NextRow, 7).Formula = "='[" & FiletoList & "]Cover'!R20C5"
    Cells(NextRow, 8).Formula = "='[" & FiletoList & "]Cover'!R21C5"
    NextRow = NextRow + 1 'Move to next row
    FiletoList = Dir 'Dir returns the next Excel workbook in the folder
Loop

Application.ScreenUpdating = True

End Sub
于 2014-01-06T09:17:49.073 回答
0

这是你正在尝试的吗？（未经测试）

'~~> Change this to the directory which has .xlsx files
Const sDir = "C:\Temp\"

Sub Sample()
    Dim ws As Worksheet
    Dim i As Long, num As Long, Calcmode As Long
    Dim FilesCount As Long, startNum As Long

    On Error GoTo Whoa

    Set ws = ThisWorkbook.Sheets("Sheet1")

    With Application
        .ScreenUpdating = False
        Calcmode = .Calculation
        .Calculation = xlCalculationManual
    End With

    '~~> Get the number of files in that directory
    FilesCount = getFileCount(sDir)

    startNum = 1

    If FilesCount <> 0 Then
        With ws
            For i = 4 To (FilesCount + 3)
                num = Format(startNum, "000")

                .Range("C" & i).Formula = "='[413-05-" & num & ".xlsx]Cover'!R4C5"
                .Range("D" & i).Formula = "='[413-05-" & num & ".xlsx]Cover'!R5C3"
                .Range("E" & i).Formula = "='[413-05-" & num & ".xlsx]Order'!R27C9"
                .Range("F" & i).Formula = "='[413-05-" & num & ".xlsx]Cover'!R8C9"

                startNum = startNum + 1
            Next i
        End With
    End If

LetsContinue:
    With Application
        .ScreenUpdating = True
        .Calculation = Calcmode
    End With
    Exit Sub
Whoa:
    MsgBox Err.Description
    Resume LetsContinue
End Sub

Function getFileCount(s As String) As Long
    Dim Path As String, Filename As String
    Dim Count As Long

    Path = s & "*.xlsx"

    Filename = Dir(Path)

    Do While Filename <> ""
        Count = Count + 1
        Filename = Dir()
    Loop

    getFileCount = Count
End Function
于 2013-10-29T09:11:28.377 回答