| |
コピー元の「セル」とコピー先の「列」を指定できるようにしてみました。
Private Sub CommandButton2_Click()
Dim ファイル As String
Dim 一覧 As String
Dim Result As Long
'##################################
' 同フォルダ内のExcelファイル検出
'##################################
ファイル = Dir("*.xls")
Do While ファイル <> ""
If ファイル = ThisWorkbook.Name Then ファイル = ""
一覧 = 一覧 & Chr(13) & ファイル
ファイル = Dir()
Loop
Result = MsgBox("以下のファイルが見つかりました。実行しますか？" & Chr(13) & 一覧, 4, "ファイル確認")
If Result = 7 Then
Exit Sub
End If
'########################
' 抽出データの範囲指定
'########################
Dim コピー元 As String
Dim コピー先 As String
On Error GoTo 範囲エラー
コピー元 = Application.InputBox("コピー元のセルの番地を入力して下さい。")
コピー先 = Application.InputBox("コピー先の列を入力して下さい。")
Result = MsgBox("セル" & コピー元 & " の値を" & コピー先 & "列 に抽出します。", 1, "抽出範囲確認")
If Result = 2 Then
Exit Sub
End If
'########################
' データのコピー
'########################
ファイル = Dir("*.xls")
Do While ファイル <> ""
If ファイル <> ThisWorkbook.Name Then
'ファイルを開く
Workbooks.Open Filename:=ファイル
'コピー元 → コピー先
ThisWorkbook.Worksheets("sheet1").Range(コピー先 & "65536"). _
End(xlUp).Offset(1, 0).Value = _
ActiveWorkbook.Worksheets("sheet1").Range(コピー元).Value
'ファイルを閉じる
ActiveWorkbook.Close
End If
ファイル = Dir()
Loop
ThisWorkbook.Worksheets("sheet1").Range(コピー先 & "1").Delete Shift:=xlUp
Exit Sub
範囲エラー:
MsgBox "入力した値が、正しくありません。"
ActiveWorkbook.Close
End Sub
|
|
INA
- 03/9/4(木) 10:11 -
