| |
▼ケメ子 さん：
デバッグ完了（だと思いますが・・・）
１ヶ所、今月ファイルの固定のD列も前月ファイル用の変数にしていたところがありました。
修正版、アップします。
Sub Sample作業()
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 bPath As String 'サーバパス
Dim bBook As Workbook 'ブック
Dim bSh As Worksheet 'シート
Dim bTop As Long 'データ開始行
Dim bCol As String 'シートごとのデータ開始列
Dim bRows As Long 'シートごとのデータ数
'前月度関連
Dim oPath As String 'サーバパス
Dim oBook As Workbook 'ブック
Dim oSh As Worksheet 'シート
Dim oTop As Long 'データ開始行
Dim oCol As String 'シートごとのデータ開始列
Dim oRows As Long 'シートごとのデータ数
Dim oName As String 'ブック名。元データも同じ。
Dim oKey As String 'シートごとのkeyコード列
Dim oList As String 'keyコード列から始まるVLOOKUPリスト領域アドレス
Dim decCol As Long '同上領域のデコード列番号(1〜)
'今月度関連
Dim nPath As String 'サーバパス
Dim nBook As Workbook 'ブック
Dim nSh As Worksheet 'シート
Dim nTop As Long 'データ開始行
Dim nName As String 'ブック名
Dim nRank As Object 'ランクデコード領域
Dim nRows As Long 'シートごとのデータ数
Dim nBottom As Long 'シートごとのデータ最終行
Application.ScreenUpdating = False
Set myFso = CreateObject("Scripting.FileSystemObject")
bPath = "c:\元データ" '実際のサーバパス名に
nPath = "c:\今月度" '実際のサーバパス名に
oPath = "c:\前月度提出用" '実際のサーバパス名に
bTop = 16 '元データ開始行
oTop = 16 '前月度データ開始行
nTop = 6 '今月度データ開始行
xlRowMax = Rows.Count
For Each myFile In myFso.GetFolder(nPath).Files
nName = myFile.Name '頭に【作業】つき
oName = Mid(nName, 5) '頭の【作業】を除く
If LCase(myFso.GetExtensionName(nName)) = "xls" And _
Left(nName, 4) = "【作業】" And _
myFso.FileExists(bPath & "\" & oName) Then
Set nBook = Workbooks.Open(myFile.Path)
'------------------------------
'元ファイルから各シートへコピー
'------------------------------
Set bBook = Workbooks.Open(bPath & "\" & oName)
For Each shn In Array("A", "B", "C", "D")
Select Case shn
Case "A"
bCol = "C"
Case "B"
bCol = "F"
Case "C"
bCol = "M"
Case "D"
bCol = "E"
End Select
Set bSh = bBook.Sheets(shn)
Set nSh = nBook.Sheets(shn)
z = bSh.Range(bCol & xlRowMax).End(xlUp).Row
If z >= bTop Then '元データにデータが存在するときのみ、当シート処理
bRows = z - bTop + 1
nBottom = nTop + bRows - 1
With nSh
.Range("B6:E" & xlRowMax).ClearContents
.Range("A6:A" & xlRowMax).ClearContents
.Range("F7:I" & xlRowMax).ClearContents
.Range("B6:D6").Resize(bRows).Value = _
bSh.Range(bCol & bTop).Resize(bRows, 3).Value
.Range("F" & nTop & ":I" & nBottom).Formula = _
.Range("F" & nTop & ":I" & nTop).Formula '式をコピー
.Range("A" & nTop).Value = 1
.Range("A" & nTop).Resize(bRows).DataSeries '連番
End With
End If
Next
bBook.Close False
'----------------------------------------
'前月ファイルから各シートへランクデコード
'----------------------------------------
Set oBook = Nothing
If myFso.FileExists(oPath & "\" & oName) Then _
Set oBook = Workbooks.Open(oPath & "\" & oName)
For Each shn In Array("A", "B", "C", "D")
Select Case shn
Case "A"
oCol = "P"
oKey = "E"
Case "B"
oCol = "O"
oKey = "H"
Case "C"
oCol = "V"
oKey = "O"
Case "D"
oCol = "N"
oKey = "G"
End Select
Set nSh = nBook.Sheets(shn)
z = nSh.Range("D" & xlRowMax).End(xlUp).Row
If z >= nTop Then 'データが存在するときのみ、当シート処理
nRows = z - nTop + 1
With nSh
Set nRank = .Range("E" & nTop).Resize(nRows)
If Not oBook Is Nothing Then
Set oSh = oBook.Sheets(shn)
z = oSh.Range(oCol & xlRowMax).End(xlUp).Row
If z >= oTop Then
oRows = z - oTop + 1
oList = "[" & oBook.Name & "]" & oSh.Name & "!" & _
Range(oKey & oTop & ":" & oCol & z).Address
decCol = Columns(oCol).Column - Columns(oKey).Column + 1
nRank.Formula = _
"=VLOOKUP(D" & nTop & "," & oList & "," & decCol & ",FALSE)"
nRank.Value = nRank.Value
Else
nRank.Formula = "#N/A" '前月ブックの当該シートにデータがない時
End If
Else
nRank.Formula = "#N/A" '前月ブックがない時
End If
End With
End If
Next
'-------------------------------
'ブック処理完了 --> 次のブックへ
'-------------------------------
If Not oBook Is Nothing Then oBook.Close False
nBook.Close True
End If
Next
Set nBook = Nothing
Set oBook = Nothing
Set bBook = Nothing
Set nSh = Nothing
Set oSh = Nothing
Set bSh = Nothing
Set nRank = Nothing
Set myFso = Nothing
Application.ScreenUpdating = True
MsgBox "処理が終了しました。"
End Sub
|
|
UO3
- 11/2/17(木) 11:02 -
