| |
UO3さま
遅くなりまして申し訳ございません、ケメ子です。
会社ではネット不可のため、メールも使用できず、印刷したものを自宅で入力いたしましたので、ご覧いただきたいと思います。
*********************************
Sub 作業ファイル作成()
Dim myFso As Object
Dim myFiles As Object
Dim myFile As Object
Dim shn As Variant
Dim z As Long
Dim xlRowMax As Long
'元データ関連････a
Dim aPath As String
Dim aBook As Workbook
Dim aSh As Worksheet
Dim aTop As Long
Dim aCol As String
Dim aRows As Long
Dim aName As String
'前月提出用データ関連････b
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 bKey As String
Dim bList As String
Dim decCol As Long
'今月作業用データ関連････c
Dim cPath As String
Dim cBook As Workbook
Dim cSh As Worksheet
Dim cTop As Long
Dim cName As String
Dim cRank As Object
Dim cRows As Long
Dim cBottom As Long
Application.ScreenUpdating = False
Set myFso = CreateObject("Scripting.FileSystemObject")
aPath = ThisWorkbook.Sheets(1).Range("D4").Value '元データ(a)の保存先セル
bPath = ThisWorkbook.Sheets(1).Range("D5").Value '前月提出用データ(b)の保存先セル
cPath = ThisWorkbook.Sheets(1).Range("K4").Value '今月作業用データ(c)の保存先セル
shn2 = ThisWorkbook.Sheets(1).Range("D8").Value 'シートAのシート名入力セル
shn3 = ThisWorkbook.Sheets(1).Range("D9").Value 'シートBのシート名入力セル
shn4 = ThisWorkbook.Sheets(1).Range("D10").Value 'シートCのシート名入力セル
shn5 = ThisWorkbook.Sheets(1).Range("D11").Value 'シートDのシート名入力セル
aTop = ThisWorkbook.Sheets(1).Range("D12").Value '元データ開始行
bTop = ThisWorkbook.Sheets(1).Range("D12").Value '前月データ開始行（元データと同じ=16行目）
cTop = ThisWorkbook.Sheets(1).Range("K11").Value '今月データ開始行（6行目）
xlRowMax = Rows.Count
For Each myFile In myFso.GetFolder(aPath).Files
aName = myFile.Name
cName = ThisWorkbook.Sheets(1).Range("K5").Value & myFile.Name '頭にセルK5の値（【作業】）付き
If LCase(myFso.GetExtensionName(aName)) = "xls" And _
myFso.FileExists(cPath & "\" & cName) Then
Set cBook = Workbooks.Open(cPath & "\" & cName, UpdateLinks:=3) 'リンクの更新して開く
'------------------------------
'元ファイルから各シートへコピー
'------------------------------
Set aBook = Workbooks.Open(aPath & "\" & aName, Password:=ThisWorkbook.Sheets(1).Range("D7").Value) 'セルD7のパスワードで開く
For Each shn In Array(shn2, shn3, shn4, shn5)
Select Case shn
Case shn2
aCol = ThisWorkbook.Sheets(1).Range("E13").Value
'元データのシートAの「証券銘柄名」「証券銘柄コード」「Keyコード」範囲 開始列（C列）
Case shn3
aCol = ThisWorkbook.Sheets(1).Range("E14").Value
'元データのシートBの「証券銘柄名」「証券銘柄コード」「Keyコード」範囲 開始列（F列）
Case shn4
aCol = ThisWorkbook.Sheets(1).Range("E15").Value
'元データのシートCの「証券銘柄名」「証券銘柄コード」「Keyコード」範囲 開始列（M列）
Case shn5
aCol = ThisWorkbook.Sheets(1).Range("E16").Value
'元データのシートDの「証券銘柄名」「証券銘柄コード」「Keyコード」範囲 開始列（E列）
End Select
Set aSh = aBook.Sheets(shn)
Set cSh = cBook.Sheets(shn)
z = aSh.Range(aCol & xlRowMax).End(xlUp).Row
If z >= aTop Then
aRows = z - aTop + 1
cBottom = cTop + aRows - 1
With cSh
.Range(ThisWorkbook.Sheets(1).Range("R13").Value & xlRowMax).ClearContents
'消去範囲1（B6:D）が記載されているセル番地
.Range(ThisWorkbook.Sheets(1).Range("R14").Value & xlRowMax).ClearContents
'消去範囲2（E6:E）が記載されているセル番地
.Range(ThisWorkbook.Sheets(1).Range("R15").Value & xlRowMax).ClearContents
'消去範囲3（A6:A）が記載されているセル番地
.Range(ThisWorkbook.Sheets(1).Range("R16").Value & xlRowMax).ClearContents
'消去範囲4（F7:I）が記載されているセル番地
.Range(ThisWorkbook.Sheets(1).Range("R18").Value).Resize(aRows).Value = _
aSh.Range(aCol & aTop).Resize(aRows, 3).Value
.Range(ThisWorkbook.Sheets(1).Range("M18").Value & cTop & ":" & ThisWorkbook.Sheets(1).Range("O18").Value & cBottom).Formula = _
.Range(ThisWorkbook.Sheets(1).Range("M18").Value & cTop & ":" & ThisWorkbook.Sheets(1).Range("O18").Value & cTop).Formula
.Range(ThisWorkbook.Sheets(1).Range("K12").Value & cTop).Value = 1
.Range (ThisWorkbook.Sheets(1).Range("K12").Value & cTop), Resize(aRows).DataSeries
End With
End If
Next
aBook.Close False
'----------------------------------------
'前月ファイルから各シートへランクデコード
'----------------------------------------
Set bBook = Nothing
If myFso.FileExists(bPath & "\" & aName) Then _
Set bBook = Workbooks.Open(bPath & "\" & aName, Password:=ThisWorkbook.Sheets(1).Range("D7").Value)
For Each shn In Array(shn2, shn3, shn4, shn5)
Select Case shn
Case shn2
bCol = ThisWorkbook.Sheets(1).Range("E17").Value
bKey = ThisWorkbook.Sheets(1).Range("G13").Value
Case shn3
bCol = ThisWorkbook.Sheets(1).Range("E18").Value
bKey = ThisWorkbook.Sheets(1).Range("G14").Value
Case shn4
bCol = ThisWorkbook.Sheets(1).Range("E19").Value
bKey = ThisWorkbook.Sheets(1).Range("G15").Value
Case shn5
bCol = ThisWorkbook.Sheets(1).Range("E20").Value
bKey = ThisWorkbook.Sheets(1).Range("G16").Value
End Select
Set cSh = cBook.Sheets(shn)
z = cSh.Range(ThisWorkbook.Sheets(1).Range("P13").Value & xlRowMax).End(xlUp).Row
If z >= cTop Then
cRows = z - cTop + 1
With cSh
Set cRank = .Range(ThisWorkbook.Sheets(1).Range("K17").Value & cTop).Resize(cRows)
If Not bBook Is Nothing Then
Set bSh = bBook.Sheets(shn)
z = bSh.Range(bCol & xlRowMax).End(xlUp).Row
If z >= bTop Then
bRows = z - bTop + 1
bList = "[" & bBook.Name & "]" & bSh.Name & "!" & _
Range(bKey & bTop & ":" & bCol & z).Address
decCol = Columns(bCol).Column - Columns(bKey).Column + 1
cRank.Formula = _
"=VLOOKUP(D" & cTop & "," & bList & "," & decCol & ",FALSE)"
cRank.Value = cRank.Value
Else
cRank.Formula = "#N/A"
End If
Else
cRank.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 cRank = Nothing
Set myFso = Nothing
Application.ScreenUpdating = True
Msg.Box "処理が終了しました。"
End Sub
*****************************
こちらになりますが、コンパイルしてみたところ、会社では出なかったエラーが出てきました。
'------------------------------
'元ファイルから各シートへコピー
'------------------------------
の
> .Range(ThisWorkbook.Sheets(1).Range("M18").Value & cTop & ":" & ThisWorkbook.Sheets(1).Range("O18").Value & cBottom).Formula = _
> .Range(ThisWorkbook.Sheets(1).Range("M18").Value & cTop & ":" & ThisWorkbook.Sheets(1).Range("O18").Value & cTop).Formula
> .Range(ThisWorkbook.Sheets(1).Range("K12").Value & cTop).Value = 1
> .Range (ThisWorkbook.Sheets(1).Range("K12").Value & cTop), Resize(aRows).DataSeries
で、最後の「Resize」の部分で、「subまたはFunctionが定義されていない」とのコンパイルエラーがでてしまいました。
会社では、次の段階の「VLOOKUP」の式が黄色くなってしまったのに、どこが抜けているのでしょう。
とりあえず、コードは新規ブックの何も入力されていないものにモジュールシートだけ挿入して入力しているので、そのせいでしょうか？
ちなみに「VLOOKUP」の部分だけは、セル参照せずに、「D」列をコードの中に組み込んでみましたが、会社ではこれでもエラーが出てしまいました。
これだけではイメージがおそらく湧きにくいとは思いますので、ご不明な点がありましたら、なんなくお知らせください。
本当に申し訳ありません…
|
|
ケメ子
- 11/2/22(火) 0:44 -
