| |
▼ケメ子 さん：
さてコード案です。
これが、ケメ子さんにとって役立つのか、かえって煩雑なのかは、心もとないのですが。
なお、【作業】を外出しにしたことから、ケメ子さんのほうで、
元データを抽出-->それに紐つく今月データを読み込む
という流れに変更されていましたが、外出しにしながらも、コードで対応可能でしたので
もともとの 今月データを抽出-->それに紐つく元データを読み込む
このように、元戻ししてあります。
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
|
|
UO3
- 11/2/23(水) 13:38 -
