-1

我需要复制 excel 表并将其放入一个合并的 excel 工作簿中。合并工作表后，所有文件都需要移动到名为“原始”的新文件夹中。该文件夹应在文件所在的位置创建。

问题是文件将由用户自己选择

我正在使用 getfilename 从用户那里获取路径

涉及步骤：

Step1：例如：如果用户需要选择

C:\我的文档\worksheet1.xls
C:\我的文档\worksheet2.xls
C:\我的文档\worksheet3.xls

第 2 步：文件应合并为 worksheet1.xls 和

step3: 文件夹应该在 c:\my documents\original 中创建

并且所有 worksheet1, worksheet2,worksheet3 都应该移到“原始”文件夹中

我有合并 excelsheets 的代码。但我不知道如何在路径中创建一个文件夹。请帮助我

下面是代码

Option Explicit

Sub copyma()

Dim wb(20) As Variant
Dim ws(20) As Variant
Dim lastrow As Variant
Dim lastr(20) As Variant
Dim nextrow As Variant
Dim tempwb As Variant
Dim tempws As Worksheet
Dim tempfile As Variant
Dim fnum As Variant
Dim ws1 As Worksheet
Dim m As Integer
Dim ffiles(20) As Variant
Dim nextlastrow As Variant
Dim lastcopyrow As Variant
Dim lastcopycol As Variant

Set ws1 = Worksheets("sheet1")

fnum = ws1.Range("b3").Value
'selecting temporary files

MsgBox " plz select the temp sheet"
tempfile = Application.GetOpenFilename

Set tempwb = Workbooks.Open(Filename:=tempfile)
Set tempws = tempwb.Worksheets("sheet1")
tempws.Cells.Clear

' sleecting number of files
For m = 1 To fnum
    MsgBox " Please Select " & m & "files"
    ffiles(m) = Application.GetOpenFilename
Next m

' opening the files and copying to the temp sheet
For m = 1 To fnum
    Set wb(m) = Workbooks.Open(Filename:=ffiles(m))
    Set ws(m) = wb(m).Worksheets("sheet")
    ws(m).AutoFilterMode = False
    ' finding the lastrow of the temp sheet
    lastrow = tempws.Range("A" & tempws.Rows.Count).End(xlUp).Row
    lastr(m) = ws(m).Range("A" & ws(m).Rows.Count).End(xlUp).Row
    MsgBox lastr(m)
    nextlastrow = lastrow + 1
    With ws(m)
        lastcopyrow = .Range("A" & .Rows.Count).End(xlUp).Row
        lastcopycol = ws(m).Cells(1, .Columns.Count).End(xlToLeft).Column
        '   lastcol = ws2.Cells(1, .Columns.Count).End(xlToLeft).Column
        If m = 1 Then
            .Range("A1", .Cells(lastcopyrow, lastcopycol)).Copy tempws.Cells(lastrow, 1)
        Else
            .Range("A2", .Cells(lastcopyrow, lastcopycol)).Copy tempws.Cells(nextlastrow, 1)
        End If
    End With
    wb(m).Close
Next m

tempws.Name = "sheet"
tempwb.Save

End Sub
4

2 回答 2

0

考虑到您可以使用基本路径：

Sub Create_Path()

Dim sBase_Path As String
Dim sNew_Path As String

sBase_Path = "U:\"
sNew_Path = sBase_Path & "New_Path" 'Define yourself 

MkDir sNew_Path

End Sub
于 2013-01-23T15:39:08.390 回答
0 
'Get file path
Dim outfolder As String
outfolder = Mid(tmpfile, 1, InStrRev(tmpfile, "\")) & "original"
'Check if directory exists and create it if it does not
If Dir(outfolder) = "" Then
MkDir outfolder
End If
于 2013-01-23T15:47:03.097 回答