Excel VBA質問箱 IV

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

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


13915 / 76732 ←次へ | 前へ→

【68317】Re:VLOOKUPを使ったデータの参照
回答  UO3  - 11/2/23(水) 13:38 -

引用なし
パスワード
   ▼ケメ子 さん:

さてコード案です。
これが、ケメ子さんにとって役立つのか、かえって煩雑なのかは、心もとないのですが。
なお、【作業】を外出しにしたことから、ケメ子さんのほうで、

元データを抽出-->それに紐つく今月データを読み込む

という流れに変更されていましたが、外出しにしながらも、コードで対応可能でしたので

もともとの 今月データを抽出-->それに紐つく元データを読み込む

このように、元戻ししてあります。

Option Explicit

Enum Rayout   'データシートのレイアウト規定
   stLayout
   POSaPath      '元パス
   POSbPath      '前月パス
   POScPath      '今月パス
   POSshn2       'シートAのシート名
   POSshn3       'シートBのシート名
   POSshn4       'シートCのシート名
   POSshn5       'シートDのシート名
   POSaTop       '元 データ開始行
   POSaCol2      '元 シートAのデータ開始列
   POSaCol3      '元 シートBのデータ開始列
   POSaCol4      '元 シートCのデータ開始列
   POSaCol5      '元 シートDのデータ開始列
   POSbTop       '前月 データ開始行
   POSbkey2      '前月 シートAのkeyデータ列
   POSbkey3      '前月 シートBのkeyデータ列
   POSbkey4      '前月 シートCのkeyデータ列
   POSbkey5      '前月 シートDのkeyデータ列
   POSbrank2      '前月 シートAのランク列
   POSbrank3      '前月 シートBのランク列
   POSbrank4      '前月 シートCのランク列
   POSbrank5      '前月 シートDのランク列
   POScTop       '今月 データ開始行
   POScCol       '今月 データ開始列
   POScKey       '今月 keyデータ列
   POScRank      '今月 ランク列
   POScformula     '今月 式の開始列
   POScnosform     '今月 式の列数
   POScopycols     '元->今月 コピー列数
   POScPre       '今月ファイルの接頭文字列
   edLayout
  End Enum
 
Sub Sample作業2()
  Dim v As Variant   'レイアウト情報格納配列
  Dim myFso As Object
  Dim myFiles As Object
  Dim myFile As Object
  Dim shn As Variant  'シート名 A,B,C,D
  Dim z As Long
  Dim xlRowMax As Long 'エクセル最大行数

  '元データ関連
  Dim aBook As Workbook 'ブック
  Dim aSh As Worksheet 'シート
  Dim aCol As String  'シートごとのデータ開始列
  Dim aRows As Long   'シートごとのデータ数
  Dim aName As String  'ブック名。前月データも同じ。
  '前月度関連
  Dim bBook As Workbook 'ブック
  Dim bSh As Worksheet 'シート
  Dim bCol As String  'シートごとのデータ開始列
  Dim bRank As String  'シートごとのランク列
  Dim bRows As Long   'シートごとのデータ数
  Dim bName As String  'ブック名。元データも同じ。
  Dim bKey As String  'シートごとのkeyコード列
  Dim bList As String  'keyコード列から始まるVLOOKUPリスト領域アドレス
  Dim decCol As Long  '同上領域のデコード列番号(1〜)
  '今月度関連
  Dim cBook As Workbook 'ブック
  Dim cSh As Worksheet 'シート
  Dim cName As String  'ブック名
  Dim cDecR As Object  'ランクデコード領域
  Dim cRows As Long   'シートごとのデータ数
  Dim cBottom As Long  'シートごとのデータ最終行

  Application.ScreenUpdating = False
  Set myFso = CreateObject("Scripting.FileSystemObject")
 
  With ThisWorkbook.Worksheets("Layout")
   v = Application.Transpose(.Range("B1").Resize(edLayout - 1).Value)
   xlRowMax = .Rows.Count
  End With
 
  For Each myFile In myFso.GetFolder(v(POScPath)).Files
   cName = myFile.Name             '頭に【作業】つき
   aName = Replace(cName, v(POScPre), "", , 1) '頭の【作業】を除く
   bName = aName
 
   If LCase(myFso.GetExtensionName(cName)) = "xls" And _
      Left(cName, Len(v(POScPre))) = v(POScPre) And _
      myFso.FileExists(v(POSbPath) & "\" & bName) Then
 
     Set cBook = Workbooks.Open(myFile.Path)
'------------------------------
'元ファイルから各シートへコピー
'------------------------------
     Set aBook = Workbooks.Open(v(POSaPath) & "\" & bName)
 
     For Each shn In Array(v(POSshn2), v(POSshn3), v(POSshn4), v(POSshn5))
      Select Case shn
        Case v(POSshn2)
         aCol = v(POSaCol2)
        Case v(POSshn3)
         aCol = v(POSaCol3)
        Case v(POSshn4)
         aCol = v(POSaCol4)
        Case v(POSshn5)
         aCol = v(POSaCol5)
      End Select
 
      Set aSh = aBook.Sheets(shn)
      Set cSh = cBook.Sheets(shn)
      z = aSh.Range(aCol & xlRowMax).End(xlUp).Row
      If z >= v(POSaTop) Then '元データにデータが存在するときのみ、当シート処理
        aRows = z - v(POSaTop) + 1
        cBottom = v(POScTop) + aRows - 1
        With cSh
         .Range(v(POScCol) & v(POScTop)).Resize(xlRowMax - v(POScTop) + 1, v(POScopycols)).ClearContents
         .Range(v(POScformula) & v(POScTop) + 1).Resize(xlRowMax - v(POScTop)).ClearContents
         .Range(v(POScformula) & v(POScTop) + 1).Resize(xlRowMax - v(POScTop), v(POScnosform)).ClearContents
         .Range(v(POScCol) & v(POScTop)).Resize(aRows, v(POScopycols)).Value = _
              aSh.Range(aCol & v(POSaTop)).Resize(aRows, v(POScopycols)).Value
         .Range(v(POScformula) & v(POScTop)).Resize(cBottom - v(POScTop) + 1, v(POScnosform)).Formula = _
              .Range(v(POScformula) & v(POScTop)).Resize(, v(POScnosform)).Formula '式をコピー
         .Range(v(POScCol) & v(POScTop)).Value = 1
         .Range(v(POScCol) & v(POScTop)).Resize(aRows).DataSeries '連番
        End With
      End If
     Next
 
     aBook.Close False
 
'----------------------------------------
'前月ファイルから各シートへランクデコード
'----------------------------------------
     Set bBook = Nothing
     If myFso.FileExists(v(POSbPath) & "\" & bName) Then _
      Set bBook = Workbooks.Open(v(POSbPath) & "\" & bName)
 
     For Each shn In Array(v(POSshn2), v(POSshn3), v(POSshn4), v(POSshn5))
      Select Case shn
        Case v(POSshn2)
         bCol = v(POSbrank2)
         bKey = v(POSbkey2)
        Case v(POSshn3)
         bCol = v(POSbrank3)
         bKey = v(POSbkey3)
        Case v(POSshn4)
         bCol = v(POSbrank4)
         bKey = v(POSbkey4)
        Case v(POSshn5)
         bCol = v(POSbrank5)
         bKey = v(POSbkey5)
      End Select
 
      Set cSh = cBook.Sheets(shn)
      z = cSh.Range(v(POScCol) & xlRowMax).End(xlUp).Row
      If z >= v(POScTop) Then 'データが存在するときのみ、当シート処理
        cRows = z - v(POScTop) + 1
        With cSh
         Set cDecR = .Range(v(POScRank) & v(POScTop)).Resize(cRows)
         If Not bBook Is Nothing Then
           Set bSh = bBook.Sheets(shn)
           z = bSh.Range(bCol & xlRowMax).End(xlUp).Row
           If z >= v(POSbTop) Then
            bRows = z - v(POSbTop) + 1
            bList = "[" & bBook.Name & "]" & bSh.Name & "!" & _
                   Range(bKey & v(POSbTop) & ":" & bCol & z).Address
            decCol = Columns(bCol).Column - Columns(bKey).Column + 1
            cDecR.Formula = _
              "=VLOOKUP(" & v(POScKey) & v(POScTop) & "," & bList & "," & decCol & ",FALSE)"
            'cDecR.Value = cDecR.Value
           Else
            cDecR.Formula = "#N/A" '前月ブックの当該シートにデータがない時
           End If
         Else
           cDecR.Formula = "#N/A" '前月ブックがない時
         End If
        End With
      End If
     Next
'-------------------------------
'ブック処理完了 --> 次のブックへ
'-------------------------------
     If Not bBook Is Nothing Then bBook.Close False
     cBook.Close True
   End If
  Next

  Set cBook = Nothing
  Set bBook = Nothing
  Set aBook = Nothing
  Set cSh = Nothing
  Set bSh = Nothing
  Set aSh = Nothing
  Set cDecR = Nothing
  Set myFso = Nothing

  Application.ScreenUpdating = True

  MsgBox "処理が終了しました。"

End Sub

1 hits

【68149】VLOOKUPを使ったデータの参照 ケメ子 11/2/7(月) 0:02 質問
【68152】Re:VLOOKUPを使ったデータの参照 UO3 11/2/7(月) 11:14 発言
【68162】Re:VLOOKUPを使ったデータの参照 ケメ子 11/2/7(月) 22:43 発言
【68164】Re:VLOOKUPを使ったデータの参照 UO3 11/2/8(火) 12:45 発言
【68173】Re:VLOOKUPを使ったデータの参照 ケメ子 11/2/8(火) 22:04 発言
【68174】Re:VLOOKUPを使ったデータの参照 UO3 11/2/9(水) 11:43 発言
【68175】Re:VLOOKUPを使ったデータの参照 UO3 11/2/9(水) 12:12 発言
【68176】Re:VLOOKUPを使ったデータの参照 UO3 11/2/9(水) 12:25 発言
【68177】Re:VLOOKUPを使ったデータの参照 UO3 11/2/9(水) 13:09 発言
【68180】Re:VLOOKUPを使ったデータの参照 ケメ子 11/2/9(水) 22:11 発言
【68182】Re:VLOOKUPを使ったデータの参照 UO3 11/2/10(木) 12:26 回答
【68183】Re:VLOOKUPを使ったデータの参照 ケメ子 11/2/10(木) 23:35 発言
【68232】Re:VLOOKUPを使ったデータの参照 ケメ子 11/2/16(水) 23:15 質問
【68237】Re:VLOOKUPを使ったデータの参照 UO3 11/2/17(木) 10:29 回答
【68240】Re:VLOOKUPを使ったデータの参照 UO3 11/2/17(木) 10:43 発言
【68243】Re:VLOOKUPを使ったデータの参照 UO3 11/2/17(木) 11:02 回答
【68254】Re:VLOOKUPを使ったデータの参照 ケメ子 11/2/17(木) 22:39 発言
【68255】Re:VLOOKUPを使ったデータの参照 UO3 11/2/17(木) 23:08 発言
【68259】Re:VLOOKUPを使ったデータの参照 ケメ子 11/2/18(金) 21:14 発言
【68303】Re:VLOOKUPを使ったデータの参照 ケメ子 11/2/22(火) 0:44 質問
【68306】Re:VLOOKUPを使ったデータの参照 UO3 11/2/22(火) 9:28 発言
【68307】Re:VLOOKUPを使ったデータの参照 UO3 11/2/22(火) 9:50 発言
【68308】Re:VLOOKUPを使ったデータの参照 UO3 11/2/22(火) 10:27 発言
【68314】Re:VLOOKUPを使ったデータの参照 ケメ子 11/2/23(水) 0:19 発言
【68315】Re:VLOOKUPを使ったデータの参照 UO3 11/2/23(水) 13:32 発言
【68316】Re:VLOOKUPを使ったデータの参照 UO3 11/2/23(水) 13:36 発言
【68317】Re:VLOOKUPを使ったデータの参照 UO3 11/2/23(水) 13:38 回答
【68321】Re:VLOOKUPを使ったデータの参照 UO3 11/2/23(水) 22:04 発言
【68322】Re:VLOOKUPを使ったデータの参照 ケメ子 11/2/23(水) 22:04 質問
【68331】Re:VLOOKUPを使ったデータの参照 UO3 11/2/24(木) 11:46 発言
【68333】Re:VLOOKUPを使ったデータの参照 UO3 11/2/24(木) 11:47 発言
【68346】Re:VLOOKUPを使ったデータの参照 ケメ子 11/2/24(木) 22:46 発言
【68421】Re:VLOOKUPを使ったデータの参照2 ケメ子 11/3/3(木) 20:15 質問
【68425】Re:VLOOKUPを使ったデータの参照2 UO3 11/3/4(金) 12:32 回答
【68426】できました!! ですが・・・ ケメ子 11/3/4(金) 20:31 質問
【68429】Re:できました!! ですが・・・ UO3 11/3/4(金) 21:51 発言
【68431】Re:できました!! ですが・・・ UO3 11/3/5(土) 16:58 回答
【68432】Re:できました!! ですが・・・ ケメ子 11/3/5(土) 18:53 発言
【68441】プロシージャの追加場所 ケメ子 11/3/7(月) 21:21 質問
【68442】Re:プロシージャの追加場所 UO3 11/3/7(月) 21:59 回答
【68479】\(^o^)/ ケメ子 11/3/9(水) 20:58 お礼

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