0

次のコードはExcelワークブックを参照し、複数のワークブックを選択してそれらをすべて1つのシートに貼り付けることができますが、すべて正常に機能しますが、私の問題はそれらを貼り付けるときにファイルを区切るために間にスペースが残らないことです。助けて。

Sub Button4_Click()
Dim fileStr As Variant
Dim wbk1 As Workbook, wbk2 As Workbook
Dim ws1 As Worksheet

fileStr = Application.GetOpenFilename(FileFilter:="microsoft excel files (*.xlsx), *.xlsx", Title:="Get File", MultiSelect:=True)
Set wbk1 = ActiveWorkbook
Set ws1 = wbk1.Sheets("Sheet3")

For i = 1 To UBound(fileStr)

MsgBox fileStr(i), , GetFileName(CStr(fileStr(i)))

Set wbk2 = Workbooks.Open(fileStr(i))
wbk2.Sheets(1).UsedRange.Copy ws1.Cells(ws1.Range("A" & Rows.Count).End(xlUp).Row, 1)

wbk2.Close

Next i

End Sub
4

1 に答える 1

1

あなたの質問 (およびコメントへの回答) を正しく解釈した場合、異なるワークブックからコピーされたデータの間にスペースを入れるには、コード内の次の行を変更します。

ws1.Cells(ws1.Range("A" & Rows.Count).End(xlUp).Row, 1)

これに：

ws1.Cells(ws1.Range("A" & Rows.Count).End(xlUp).Row + 2, 1)

元のコードでは、実際には 1 つのワークブックのデータの最後の行を別のワークブックの最初の行に置き換えていました。を追加する+2と、最後にコピーされたデータ セットの 2 行下で貼り付け操作が開始され、データ セット間に空白行が 1 行できます。明らかに、+2を調整してより多くのスペースを確保してください:)

アップデート

最初のファイル プルでヘッダーのみをコピーするようにコードを修正しました。

Sub Button4_Click()

Dim fileStr As Variant
Dim wbk1 As Workbook, wbk2 As Workbook
Dim ws1 As Worksheet

fileStr = Application.GetOpenFilename(FileFilter:="microsoft excel files (*.xlsx), *.xlsx", Title:="Get File", MultiSelect:=True)
Set wbk1 = ActiveWorkbook
Set ws1 = wbk1.Sheets("Sheet3")

For i = 1 To UBound(fileStr)

    MsgBox fileStr(i), , GetFileName(CStr(fileStr(i)))

    Set wbk2 = Workbooks.Open(fileStr(i))

    If i = 1 Then ' if it's the first file, copy the headers

        wbk2.Sheets(1).UsedRange.Copy

    Else 'otherwise only copy the data (assumes headers are always in row 1

        wbk2.Sheets(1).Intersect(wbk2.Sheets(1).UsedRange, wbk2.Sheets(1).UsedRange.Offset(1)).Copy

    End If

    ws1.Cells(ws1.Range("A" & Rows.Count).End(xlUp).Row + 2, 1).PasteSpecial xlPasteAll


    wbk2.Close

Next i

End Sub
于 2012-10-15T13:57:57.357 に答える