我有一套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
答案 0 :(得分: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
答案 1 :(得分:0)
这是你在尝试什么? (的 UNTESTED 强>)
'~~> 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