用于提取数据的 VBA 编码

Question

我有 50 个 .xls 文件以用户名保存在共享驱动器上。例如：“Rahul Goswami.xls”、“Rohit Sharma.xls”等。

每个 Excel 文件包含 2 个工作表：“Case Tracker”和“Pending Tracker”。

在“案例跟踪器”工作表中，用户输入他们的日常数据/日常生产。

我希望 VBA 代码从一个单独的 Excel 工作簿中的所有 50 个 Excel 文件中提取整个“案例跟踪器”工作表，一个在另一个之下。

目前我正在将 Excel 文件中的数据复制粘贴到主工作簿到“Sheet1”。

我可以在其中输入日期，然后自动从所有 50 个文件中获取该日期的数据吗？

A 到 J 列包含下面提供的数据。此示例针对 1 个用户。

日期顾问用户 ID BP URN 阶段案例类型 先前状态 当前状态类别
10-Apr Rahul Goswami goswami 123456 98765431 1 URN New Pend abc

Sub Beachson()

Dim z As Long, e As Long, d As Long, G As Long, h As Long Dim f As String 

d = 2 
Cells(1, 1) = "=cell(""filename"")" 
Cells(1, 2) = "=left(A1,find(""["",A1)-1)" 
Cells(2, 1).Select 
f = Dir(Cells(1, 2) & "*.xls") 

Do While Len(f) > 0 
    ## Heading ## 
    ActiveCell.Formula = f
    ActiveCell.Offset(1, 0).Select
    f = Dir()
Loop 

z = Cells(Rows.Count, 1).End(xlUp).Row 

For e = 2 To z 
    If Cells(e, 1) <> ActiveWorkbook.Name Then 
        Cells(d, 2) = Cells(e, 1) 
        Cells(1, 4) = "=Counta('" & Cells(1, 2) & "[" & Cells(e, 1) & "]Case Tracker'!I:I)" 
        For h = 10 To Cells(1, 4) 
            For G = 1 To 10 
                Cells(1, 3) = "='" & Cells(1, 2) & "[" & Cells(e, 1) & "]Case Tracker'!" & Chr(G + 64) & h  
                Cells(d, G + 2) = Cells(1, 3) 
            Next G 
            d = d + 1 
        Next h 
    End If 
    d = d + 1 
Next e 

MsgBox "collating is complete."

End Sub

Answer 1

我会避免将信息存储在工作表中，然后转到 VBA，然后再转到工作表等。

至于您在打开文件时无法提取数据的问题，我建议您创建另一个Excel.Application 实例并以ReadOnly 模式从中打开文件。

这是对我有用的代码（还实现了查找特定日期的功能）：

Sub Beachson2()

Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
Dim App As Object
Set App = CreateObject("Excel.Application")
Dim wsSource As Worksheet
Dim sFold As String
sFold = ThisWorkbook.Path & "\"
Dim sFile As String
Dim i As Long, j As Long
Dim cell As Range

' Setting date
Dim sInput As String, dInput As Date
sInput = Application.InputBox("Enter A Date")
If IsDate(sInput) Then
    dInput = DateValue(sInput)
Else
    MsgBox "Invalid date. Exiting..."
    Exit Sub
End If

Application.ScreenUpdating = False

' Pulling data
i = 1
sFile = Dir(sFold & "\*.xls")
Do While sFile <> ""
    If sFile <> sFold & ThisWorkbook.Name Then
        Set wsSource = App.Workbooks.Open(Filename:=sFold & sFile, ReadOnly:=True).Sheets("Case Tracker")
        For Each cell In wsSource.Range("A1:A" & wsSource.UsedRange.Rows.Count)
            If cell.Value = CStr(dInput) Then
                With ws.Cells(Rows.Count, 1).End(xlUp)
                    If IsEmpty(.Value2) Then
                        .Value2 = sFile
                    ElseIf .Value2 <> sFile Then
                        .Offset(1).Value2 = sFile
                    Else
                        'do nothing
                    End If
                End With
                If ws.Cells(Rows.Count, 2).End(xlUp).Value2 <> sFile Then
                    ws.Cells(i, 2).Value2 = sFile
                End If
                For j = 3 To 12
                    ws.Cells(i, j).Value = wsSource.Cells(cell.Row, j - 2).Value
                Next
                i = i + 1
            End If
        Next
        wsSource.Parent.Close
    End If
    sFile = Dir()
Loop

Application.ScreenUpdating = True
App.Quit

MsgBox "collating is complete."

Set App = Nothing
End Sub

代码存储在主文件中。

即使在代码中也没有定义一种特定的 Date 格式，但我仍然认为它会导致问题。如果您发现有关日期格式的问题，请发布您使用的日期格式。