[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『同一フォルダ内にある全てのファイルを、一つのシートにまとめる方法』(q10)
下記のコードは、A1に値があった場合A〜Nまでをコピペするものですが
コピー元"調査票"シートの張り付けたい値がさまざまなセルにあります。
例えば
"調査票"シート C7セル → "統括表"ブック"進行表のB列"
"調査票"シート C8セル → "統括表"ブック"進行表のC列"
"調査票"シート K7セル → "統括表"ブック"進行表のE列"
"調査票"シート K11セル → "統括表"ブック"進行表のF列"
等・・・
という様に書き換えるにはどうしたら良いでしょうか。
ご教授よろしくお願いします。
Sub Sample()
Dim t As Single
Dim strPath As String
Dim strFileName As String
Dim WB1 As Workbook
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim lngRowCount As Long 'A列に値が入っているデータ数
t = Timer
Set WS2 = ThisWorkbook.Worksheets(1)
strPath = ThisWorkbook.Path
strFileName = Dir(strPath & "\*.xls*")
Do While strFileName <> ""
If strFileName <> ThisWorkbook.Name Then
Set WB1 = Workbooks.Open(strPath & "\" & strFileName)
Set WS1 = WB1.Worksheets(1)
With WS1.Range("A1")
lngRowCount = .Worksheet.Cells(.Worksheet.Rows.Count, .Column).End(xlUp).Row - .Row
If lngRowCount >= 1 Then
With .Resize(lngRowCount, 14).Offset(1) 'N列まで
.Copy WS2.Range("A" & WS2.Rows.Count).End(xlUp).Offset(1)
End With
End If
End With
WB1.Close False
End If
strFileName = Dir
Loop
End Sub
< 使用 Excel:Excel2010、使用 OS:Windows7 >
Sub Sample() Dim strPath As String Dim strFileName As String Dim WS2 As Worksheet Dim iR As Long
Application.ScreenUpdating = False iR = 1
Set WS2 = ThisWorkbook.Worksheets(1) strPath = ThisWorkbook.Path strFileName = Dir(strPath & "\*.xls*")
Do While strFileName <> "" If strFileName <> ThisWorkbook.Name Then With Workbooks.Open(strPath & "\" & strFileName) With .Sheets(1) iR = iR + 1 WS2.Cells(iR, "B").Value = .Range("C7") WS2.Cells(iR, "C").Value = .Range("C8") WS2.Cells(iR, "E").Value = .Range("K7") WS2.Cells(iR, "F").Value = .Range("K11") End With .Close False End With End If strFileName = Dir Loop
Application.ScreenUpdating = True End Sub (???) 2016/06/27(月) 14:58
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.