0

次のコードを使用すると、複数の異なるexcelファイルを参照して、それらを1枚のシートの下に貼り付けることができます。excelファイルの列名は同じですが、データが異なり、正常に機能しています。問題は、必要なときに必要になることです。ファイルを貼り付ける貼り付けるファイルごとにそのファイルの名前を書き込む必要があります。私のexcelファイルの名前はFamilycarと呼ばれ、他のexcelのファイル名はsmartcarと呼ばれます。

例

eg1 CarName、Fuel、Colour

BMW、ガソリン、赤

フォード、ディーゼル、グリーン

マツダ、ガソリン、グレー

eg2 CarName、Fuel、Colour

オースティン、ガソリン、ブルー

VW、ディーゼル、ホワイト

アウディ、ガソリン、ブラック

結果

CarName、Fuel、Colour、FileName

BMW、ガソリン、赤、ファミリーカー

フォード、ディーゼル、グリーン、ファミリーカー

マツダ、ガソリン、グレー、ファミリーカー

オースティン、ガソリン、青、smatrtcar

VW、ディーゼル、ホワイト、スマートカー

アウディ、ガソリン、ブラック、スマートカー

   Sub Button5_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")

 'handling first file seperately
 MsgBox fileStr(1), , GetFileName(CStr(fileStr(1)))
 Set wbk2 = Workbooks.Open(fileStr(1))
 wbk2.Sheets(1).UsedRange.Copy ws1.Cells(ws1.Range("A" & Rows.Count).End(xlUp).Row + 2, 1)

 wbk2.Close

 For i = 2 To UBound(fileStr)
 MsgBox fileStr(i), , GetFileName(CStr(fileStr(i)))

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

 wbk2.Sheets(1).UsedRange.Offset(1, 0).Copy ws1.Cells(ws1.Range("A" & Rows.Count).End(xlUp).Row + 2, 1)


 wbk2.Close
 Next i
4

2 に答える 2

3

この要件を含めるためにリファクタリングされたコードは次のとおりです

Sub Button5_Click()
    Dim fileStr As Variant
    Dim wbk1 As Workbook, wbk2 As Workbook
    Dim ws1 As Worksheet
    Dim rngSource As Range
    Dim rngDest As Range
    Dim rwOffset As Long
    Dim sFileName As String

    Dim i As Long

    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)))

        ' Used to change copy range for first file, without repeating code
        rwOffset = IIf(i = 1, 0, 1)
        Set wbk2 = Workbooks.Open(fileStr(i))

        ' File Name without extension
        sFileName = Left$(wbk2.Name, InStrRev(fileStr(i), ".") - 1)  

        Set rngSource = wbk2.Sheets(1).UsedRange.Offset(rwOffset, 0)
        Set rngDest = ws1.Cells(ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row + 2, 1)

        rngSource.Copy rngDest

        ' Add filename next to pasted data
        rngDest.Offset(0, rngSource.Columns.Count).Resize(rngSource.Rows.Count, 1) = sFileName
        wbk2.Close
    Next i

End Sub
于 2012-10-17T07:59:42.747 に答える
1

コードに追加する

' ws1 is the result/output worksheet
' wbk2 is the input workbook I assume
Dim fromRow As Long
Dim toRow As Long
Dim colNum As Long 'please defind the column Number to output the workbook's name
' In your example, it would be 4
colNum = 4
fromRow = ws1.Cells(ws.Rows.Count, 1).End(xlUp).Row + 1
wbk2.Sheets(1).UsedRange.Offset(1, 0).Copy ws1.Cells(ws1.Range("A" & Rows.Count).End(xlUp).Row + 2, 1)
toRow = ws1.Cells(ws.Rows.Count, 1).End(xlUp).Row
ws1.Range(ws1.Cells(fromRow, colNum), ws1.Cells(toRow, colNum)).Value = wbk2.Name
于 2012-10-17T07:53:23.693 に答える