VBA编码以提取数据

Question

I have 50 .xls files saved on a shared drive by the name of users. Eg: "Rahul Goswami.xls", "Rohit Sharma.xls", etc.

Each Excel file contains 2 worksheets: "Case Tracker" and "Pending Tracker".

In the "Case Tracker" worksheet users put their daily data/ daily production.

I wanted VBA code to pull the entire "Case Tracker" worksheet from all 50 Excel files in one separate Excel workbook, one below the other.

Currently I am copy-pasting the data from the Excel files to the master workbook to "Sheet1".

Can there be something where I put the date and the data will come automatically for that date from all the 50 files?

Column A to J contains the data provided below. This example is given for 1 user.

Date    Advisor            Userid      BP         URN            Stage  Case Type  Previous Status       Current status        Category
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

I would avoid storing information in sheet, then going to VBA, then again to sheet, etc.

As for your problem of not being able to pull data when a file is open, I would suggest creating another instance of Excel.Application and opening files from it in ReadOnly mode.

This is the code which worked for me (the ability to find particular dates is also implemented):

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

The code is stored in the master file.

Even in the code there is no one specific Date format defined, but I still think it is capable of causing problems. If you find problems regarding date formats, please post your used date format.