-1

エクセルシートをコピーして、1つの統合されたエクセルワークブックにする必要があります。ワークシートを統合した後、すべてのファイルを「Orginial」という新しいフォルダに移動する必要があります。フォルダは、ファイルが配置されている場所に作成する必要があります。

問題は、ファイルがユーザー自身によって選択されることです

getfilenameを使用してユーザーからパスを取得しています

含むステップ：

ステップ1：例：ユーザーが選択する必要がある場合

C：\ mydocuments \ ワークシート1.xlsC
：\ mydocuments \ worksheet2.xls
C：\ mydocuments \worksheet3.xls

step2：fileはworksheet1.xlsとして統合する必要があります

step3：フォルダはc：\ mydocuments\originalに作成する必要があります

そして、すべてのworksheet1、worksheet2、worksheet3は、「元の」フォルダに移動する必要があります

エクセルシートを統合するためのコードがあります。しかし、パス内にフォルダを作成する方法がわかりません。助けてください

以下はコードです

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 に答える