Question

我必须从多个以数字命名的excel文件中复制数据（1.xlsx，2.xlsx，3.xlsx等）。我写了这个宏。它运行。但是没有副本发生，我运行宏的主要工作簿仍然是空的。

Sub filecopy()
' The macro is running in the main file, wich I saved as .xlsm    
' This main.xlsm is in the same folder as the files from wich I copy the data

Dim Filename As String, Pathname As String,xx as Double
Activesheet.Usedrange.Clear 'I delete the current contents fo the sheet

Pathname = ActiveWorkbook.Path
Filename = Dir(Pathname & "*.xlsx")
xx = 1 'the first column where the contents of the first file go

Do While Len(Filename) > 0

    Cells(1, xx).Formula = "='[" & Filename & "]Sheet1'!A1" 
    Cells(2, xx).Formula = "='[" & Filename & "]Sheet1'!B2"
    Cells(3, xx).Formula = "='[" & Filename & "]Sheet1'!C3"

    xx = xx + 1 'next file next column
    Filename = Dir() 
    Loop
    ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value 'every formula goes to value    
MsgBox "Work Complete", vbInformation
End Sub

Answer 1

您的代码中有2个错误：

<强> 1。 \缺失了 - ＆gt; filename为空

将Filename = Dir(Pathname & "*.xlsx")替换为Filename = Dir(Pathname & "\*.xlsx")

<强> 2。公式不正确 - ＆gt;不完整的文件名

更改公式，例如Cells(1, xx).Formula = "='[" & Filename & "]Sheet1'!A1"

Cells(1, xx).Formula = "='" & Pathname & "\[" & Filename & "]Sheet1'!A1"

Answer 2

这样的解决方案怎么样：

Pathname = ActiveWorkbook.Path 'Be sure is the rigth path
Filename = Dir(Pathname & "\*.xlsx") 'I've addedd a "\"
xx = 1
Do While Len(Filename) > 0
    If Filename <> ThisWorkbook.Name Then
        Set mFile = Workbooks.Open(Pathname & "\" & Filename)
    Else
        GoTo NextFile
    End If
    With mFile.ActiveSheet 'Use the sheet you need here
        Cells(1, xx) = .Cells(1, 1).Value
        Cells(2, xx) = .Cells(2, 1).Value
        Cells(3, xx) = .Cells(3, 1).Value
    End With

    xx = xx + 1 'next file next column
    Application.DisplayAlerts = False
    mFile.Close savechanges:=False
    Application.DisplayAlerts = True
    Set mFile = Nothing
NextFile:
    Filename = Dir()
Loop

Excel从文件复制到文件宏不起作用

2 个答案: