Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


58405 / 76732 ←次へ | 前へ→

【23056】Re:違うフォルダのファイル名の一部が同...
回答  G-Luck  - 05/3/11(金) 16:21 -

引用なし
パスワード
   ▼MIKA さん:

二つ示します。
一つは最低限のコード
もう一つは、出来るだけ配慮をしたコードです。

1を使う場合は、
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)'複数選択不可なので、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
0 hits

【22947】違うフォルダのファイル名の一部が同じファイルを選ぶ MIKA 05/3/8(火) 14:43 質問
【22948】Re:違うフォルダのファイル名の一部が同じ... IROC 05/3/8(火) 15:13 回答
【22951】Re:違うフォルダのファイル名の一部が同じ... MIKA 05/3/8(火) 15:29 質問
【22955】Re:違うフォルダのファイル名の一部が同... IROC 05/3/8(火) 17:09 回答
【22993】Re:違うフォルダのファイル名の一部が同... G-Luck 05/3/9(水) 16:53 発言
【23002】Re:違うフォルダのファイル名の一部が同... MIKA 05/3/9(水) 18:00 質問
【23005】Re:違うフォルダのファイル名の一部が同... G-Luck 05/3/9(水) 19:43 発言
【23051】Re:違うフォルダのファイル名の一部が同... MIKA 05/3/11(金) 13:18 質問
【23052】Re:違うフォルダのファイル名の一部が同... G-Luck 05/3/11(金) 14:16 発言
【23053】Re:違うフォルダのファイル名の一部が同... MIKA 05/3/11(金) 14:20 質問
【23056】Re:違うフォルダのファイル名の一部が同... G-Luck 05/3/11(金) 16:21 回答
【23060】Re:違うフォルダのファイル名の一部が同... MIKA 05/3/11(金) 17:16 お礼
【23115】Re:違うフォルダのファイル名の一部が同... MIKA 05/3/14(月) 10:27 質問
【23128】Re:違うフォルダのファイル名の一部が同... G-Luck 05/3/14(月) 14:26 発言
【23166】Re:違うフォルダのファイル名の一部が同... MIKA 05/3/15(火) 13:50 質問
【23170】Re:違うフォルダのファイル名の一部が同... G-Luck 05/3/15(火) 14:56 発言
【23172】Re:違うフォルダのファイル名の一部が同... MIKA 05/3/15(火) 15:22 お礼
【23173】Re:違うフォルダのファイル名の一部が同... G-Luck 05/3/15(火) 15:28 発言
【23174】Re:違うフォルダのファイル名の一部が同... MIKA 05/3/15(火) 15:32 発言
【23176】Re:違うフォルダのファイル名の一部が同... G-Luck 05/3/15(火) 15:58 発言

58405 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free