Question

我有50个.xls文件保存在共享驱动器上的用户名。例如：＆＃34; Rahul Goswami.xls＆＃34;，＆＃34; Rohit Sharma.xls＆＃34;等

每个Excel文件包含2个工作表：＆＃34; Case Tracker＆＃34;和＆＃34;等待追踪者＆＃34;。

在＆＃34; Case Tracker＆＃34;工作表用户提供他们的日常数据/日常生产。

我希望VBA代码可以拉动整个＆＃34; Case Tracker＆＃34;来自一个单独的Excel工作簿中的所有50个Excel文件的工作表，一个在另一个下面。

目前，我正在将Excel文件中的数据复制粘贴到主工作簿中，以及＃34; Sheet1＆＃34;。

我可以在某些地方放置日期，并且所有50个文件中的数据会自动生成吗？

A列到J列包含下面提供的数据。这个例子是给1个用户的。

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

我会避免将信息存储在工作表中，然后转到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 格式，但我仍然认为它能够导致问题。如果您发现有关日期格式的问题，请发布您使用的日期格式。

VBA编码来提取数据

1 个答案: