| |
▼ひぃちゃん さん：
こんにちは。
以下は Hirofumiさんのコードをトレースしながら、
我流で書いたものです。
参考まで
'------------------------------------------- 新しい標準モジュール
Option Explicit
Private Day1 As Long
Private Dayz As Long 'Sheet2の1行目 最初の日付と 最後の日付
Sub Try1()
Dim WS1 As Worksheet: Set WS1 = Worksheets("Sheet1") 'ソース
Dim WS2 As Worksheet: Set WS2 = Worksheets("Sheet2") '出力
Dim Tbl1 As Range
Dim Tbl2 As Range
Dim arry
Set Tbl1 = WS1.[A1].CurrentRegion
Set Tbl2 = WS2.[A1].CurrentRegion
Set Tbl2 = Intersect(Tbl2, Tbl2.Offset(1, 1))
Tbl2.ClearContents
arry = Tbl2.Value
Dim dic As Object
Dim v, i As Long
Set dic = CreateObject("Scripting.Dictionary")
'> Sheet2にマスターとしてA列に品目番号､1行目に日付があります｡
'品目番号の行位置をDictionaryに記憶します
v = Tbl2.Columns(0).Value
For i = 1 To UBound(v)
dic(v(i, 1)) = i
Next
Day1 = Tbl2.Item(0, 1).Value2
Dayz = Tbl2.Item(0, Tbl2.Columns.Count).Value2
'--- 以上で,出力先の<行,列座標>関係が明らかになりました
'--- これより Sheet1のデータをtbl2用配列に送り込みます
Dim n As Long, m As Long
v = Tbl1.Value
For i = 1 To UBound(v)
If dic.Exists(v(i, 1)) Then
n = dic(v(i, 1))
m = ToDate(CStr(v(i, 3)))
If m Then
arry(n, m) = v(i, 4)
End If
End If
Next
Tbl2.Value = arry '配列を Sheet2.Tbl2 に貼りつけます
Set dic = Nothing
End Sub
'文字列("12/1/10" など)を日付けに直し、
'Sheet2一行目の日付に対応した位置を返す関数
Private Function ToDate(ss As String) As Long
Dim v, i As Long
v = Split(ss, "/")
If UBound(v) = 2 Then
i = DateSerial(v(2) - (v(2) < 100) * 2000, v(0), v(1))
Select Case i
Case Day1 To Dayz
ToDate = i - Day1 + 1
End Select
End If
End Function
|
|
kanabun
- 10/10/22(金) 23:21 -
