| |
▼MIKA さん：
二つ示します。
一つは最低限のコード
もう一つは、出来るだけ配慮をしたコードです。
１を使う場合は、
myFolderA
myFolderB
にそれぞれ、対象のフォルダのパスを入力してください。
Public Sub myFileCopy1()
Const myFileNameA As String = "*200501.xls"
Const myFileNameB As String = "ABC*.xls"
Const myFolderA As String = "フォルダのパスを入力してください"
Const myFolderB As String = "フォルダのパスを入力してください"
Dim FnA As String
Dim FnB As String
Dim KENMEI As String
Dim i As Long
Dim iFn As Variant
Dim N As Long
Dim buf As Variant
'対象ファイルのサーチする。
'結果は、.FoundFiles に格納されている
With Application.FileSearch
.LookIn = myFolderA '対象フォルダ
.SearchSubFolders = False 'サブフォルダの内部も探すかどうか
.Filename = myFileNameA'検索ファイル名、ワイルドカード指定している
.Execute '実行
End With
'データコピー本文
For i = 1 To Application.FileSearch.FoundFiles.Count
'iFn にはフルパスが入っている。
iFn = Application.FileSearch.FoundFiles(i)
'ファイル名の取得
FnA = Dir(iFn) 'ファイル検索して存在するなら、ファイル名を返す。
KENMEI = Left(FnA, Len(FnA) - 10)
'県名の部分を取得。Left(文字列、左から何文字)、文字数Len(文字列)
FnB = WorksheetFunction.Substitute(myFileNameB, "*", KENMEI)
'*をKENMEIに変更
FnB = Dir(myFolderB & Application.PathSeparator & FnB)
'ファイルを開く
Workbooks.Open _
Filename:=myFolderA & Application.PathSeparator & FnA
Workbooks.Open _
Filename:=myFolderB & Application.PathSeparator & FnB
'データ数を取得
With Workbooks(FnA).Worksheets(1)
N = .Range("A2").End(xlDown).Row - .Range("A2").Row + 1
End With
'データコピー
Workbooks(FnA).Worksheets(1).Range("A2:D2").Resize(N).Copy
'コピー
Workbooks(FnB).Worksheets(1).Range("B18").PasteSpecial
'貼り付け
'ファイルを閉じる
Workbooks(FnA).Close SaveChanges:=False
'変更があっても保存せず閉じる
Workbooks(FnB).Close SaveChanges:=True
'変更があった場合保存して閉じる
Next iFn
End Sub
Public Sub myFileCopy2()
Const myFileNameA As String = "*200501.xls"
Const myFileNameB As String = "ABC*.xls"
Const myMessage1 As String = _
"フォルダが選択されていません。" & vbCrLf & _
"中止します。"
Const myMessage2 As String = "のデータが多すぎてコピーできません。"
Const myMessage3 As String = "データのコピーが終了しました。"
Dim ret As Long
Dim myFolderA As String
Dim myFolderB As String
Dim FnA As String
Dim FnB As String
Dim KENMEI As String
Dim i As Long
Dim iFn As Variant
Dim N As Long
Dim buf As Variant
'フォルダ選択
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False '複数選択
.Title = "データフォルダを選択してください。" 'ダイアログタイトル
.ButtonName = "選択" '実行ボタンキャプション
ret = .Show 'ダイアログを表示
If ret = 0 Then 'キャンセルの場合 返り値が 0、以外は -1
MsgBox myMessage1
Exit Sub
End If
myFolderA = .SelectedItems(1)'複数選択不可なので、１にしか値が無い
End With
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "出力フォルダを選択してください。"
.ButtonName = "選択"
ret = .Show
If ret = 0 Then
MsgBox myMessage1
Exit Sub
End If
myFolderB = .SelectedItems(1)
End With
'対象ファイルのサーチする。
'結果は、.FoundFiles に格納されている
With Application.FileSearch
.LookIn = myFolderA '対象フォルダ
.SearchSubFolders = False 'サブフォルダの内部も探すかどうか
.Filename = myFileNameA'検索ファイル名、ワイルドカード指定している
.Execute '実行
End With
Application.ScreenUpdating = False '表示の更新を停止
'データコピー本文
For i = 1 To Application.FileSearch.FoundFiles.Count
'iFn にはフルパスが入っている。
iFn = Application.FileSearch.FoundFiles(i)
'ファイル名の取得
FnA = Dir(iFn) 'ファイルが存在するなら、ファイル名を返す。
KENMEI = Left(FnA, Len(FnA) - 10)
'県名の部分を取得。Left(文字列、左から何文字)、文字数Len(文字列)
FnB = WorksheetFunction.Substitute(myFileNameB, "*", KENMEI)
'*をKENMEIに変更
FnB = Dir(myFolderB & Application.PathSeparator & FnB)
'ファイルBが存在するなら下記処理。無ければ処理を跳ばす。
If FnB <> "" Then
'ファイルを開く
'すでに同名ファイルが開いている場合は、開かない。
On Error Resume Next 'エラーが出ても処理を続ける
Set buf = Workbooks(FnA) '存在しない場合、エラーが出る。
If Err <> 0 Then
Workbooks.Open _
Filename:=myFolderA & Application.PathSeparator & FnA
Workbooks(FnA).IsAddin = False
End If
Err.Clear
Set buf = Workbooks(FnB)
If Err <> 0 Then
Workbooks.Open _
Filename:=myFolderB & Application.PathSeparator & FnB
Workbooks(FnB).IsAddin = False
End If
On Error GoTo 0 'エラーが出たら処理を止める
'データ数を取得
N = 0
With Workbooks(FnA).Worksheets(1).Range("A2") '
If .Value <> "" Then
If .Offset(1, 0).Value <> "" Then
N = .End(xlDown).Row - .Row + 1
Else
N = 1
End If
End If
End With
'データコピー
If 1 < N Then 'データが存在しない場合はコピーを実行しない。
'データが多すぎる場合は警告を出す。
If 65536 - 18 + 1 < N Then
MsgBox FnA & myMessage2
Else
Workbooks(FnA).Worksheets(1). _
Range("A2:D2").Resize(N).Copy 'コピー
Workbooks(FnB).Worksheets(1). _
Range("B18").PasteSpecial '貼り付け
End If
End If
'ファイルを閉じる
Workbooks(FnA).Close SaveChanges:=False
'変更があっても保存せず閉じる
With Workbooks(FnB)
.IsAddin = True
.Close SaveChanges:=True
'変更があった場合保存して閉じる
End With
End If
Next i
Application.ScreenUpdating = True
MsgBox myMessage3
End Sub
|
|
G-Luck
- 05/3/11(金) 16:21 -
