Excel VBA質問箱 IV

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

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


2596 / 13645 ツリー ←次へ | 前へ→

【66968】列と行が一致した所にデータを挿入したい ひぃちゃん 10/10/21(木) 21:58 質問[未読]
【66970】Re:列と行が一致した所にデータを挿入したい Hirofumi 10/10/21(木) 22:16 発言[未読]
【66971】Re:列と行が一致した所にデータを挿入したい ひぃちゃん 10/10/21(木) 22:32 質問[未読]
【66973】Re:列と行が一致した所にデータを挿入したい Hirofumi 10/10/22(金) 0:13 回答[未読]
【66985】Re:列と行が一致した所にデータを挿入したい ひぃちゃん 10/10/22(金) 22:32 お礼[未読]
【66986】Re:列と行が一致した所にデータを挿入したい kanabun 10/10/22(金) 23:21 発言[未読]
【66987】Re:列と行が一致した所にデータを挿入したい ひぃちゃん 10/10/23(土) 19:42 お礼[未読]
【66991】Re:列と行が一致した所にデータを挿入したい Hirofumi 10/10/24(日) 10:50 発言[未読]
【67008】Re:列と行が一致した所にデータを挿入したい ひぃちゃん 10/10/25(月) 20:16 お礼[未読]

【66968】列と行が一致した所にデータを挿入したい
質問  ひぃちゃん  - 10/10/21(木) 21:58 -

引用なし
パスワード
   Sheet1に A1にタイトル、B1に品目番号、C1に日付、D1個数があります。

Sheet2にマスターとしてA列に品目番号、1行目に日付があります。
日付は90日間で、始まる日がバラバラです。
(1/1〜3/31)だったり2/10〜5/10だったりです)
そのSheet2に品目と日付がマッチした所に個数を入れたいです。

  A | B | C | D
-|--------------------------
1|  | 1/1 | 1/2 | 1/3
-|--------------------------
2|AAA | 0 | 10 | 3
-|--------------------------
3|BBB | 2 | 1 | 0

上記の様な感じをイメージしています。
ですが、考え方が良く分からなくて困っております。

If文とLoopを使えば良い様な気もしますが、
日付の始めがばらばらだったりと混乱しています。
もしAAAで1つ隣の1つ上だったらSheet1の・・・で良く分からず。

何か良い方法がありましたら、是非お教えくださいませ。
宜しくお願い致します。

【66970】Re:列と行が一致した所にデータを挿入し...
発言  Hirofumi  - 10/10/21(木) 22:16 -

引用なし
パスワード
   1、Sheet2の表の品目と日付は記入済みで開始するのですか?
2、Sheet2の表の日付は連続しているのですか?
3、Sheet1の日付はシリアル値ですか?

【66971】Re:列と行が一致した所にデータを挿入し...
質問  ひぃちゃん  - 10/10/21(木) 22:32 -

引用なし
パスワード
   ▼Hirofumi さん:
お世話になります。

>1、Sheet2の表の品目と日付は記入済みで開始するのですか?
品目は別シートにマスターがあり、毎回それを引っ張ってきます。
日付は始めのセルに記入したらその日から90日間を表示させるようにしたいです。

>2、Sheet2の表の日付は連続しているのですか?
90日間の連続の日付となります。

>3、Sheet1の日付はシリアル値ですか?
Sheet1の日付は現在文字列になっています。
例)2010年12月1日は12/1/10となっています。

どうぞ宜しくお願い致します。

【66973】Re:列と行が一致した所にデータを挿入し...
回答  Hirofumi  - 10/10/22(金) 0:13 -

引用なし
パスワード
   こんなでは?

Sheet2のB1セルの日付はシリアル値(セル書式はなんでも可、シリアル値はB1だけでも可)で在る事
Sheet1の日付は「12/1/10」形式の文字列で在る

Option Explicit

Public Sub Sample()

  Dim i As Long
  Dim lngRows As Long
  Dim rngList As Range
  Dim rngResult As Range
  Dim vntData As Variant
  Dim dicIndex As Object
  Dim vntMax As Variant
  Dim vntMin As Variant
  Dim vntResult() As Variant
  Dim strProm As String

  'Listの先頭セル位置を基準とする(先頭列の列見出しのセル位置)
  Set rngList = Worksheets("Sheet1").Range("A1")

  '結果出力の先頭セル位置を基準とする(先頭列の列見出しのセル位置)
  Set rngResult = Worksheets("Sheet2").Range("A1")
  
  'Dictionaryオブジェクトを取得
  Set dicIndex = CreateObject("Scripting.Dictionary")
  
  'Sheet2に就いて
  With rngResult
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    '日付先頭、最終を取得
    vntMin = .Offset(, 1).Value2
    vntMax = vntMin + 90 - 1
    'A列データを配列として取得
    vntData = .Offset(1).Resize(lngRows + 1).Value
    'A列データをDictionaryに登録
    For i = 1 To lngRows
      dicIndex.Item(vntData(i, 1)) = i
    Next i
  End With
  
  '結果出力用配列を確保(2次元目は日付のシリアル値と同じにして置く)
  ReDim vntResult(1 To lngRows, vntMin To vntMax)
  
  'Sheet1に就いて
  With rngList
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row, 1).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
  End With
  
  'Sheet1先頭〜最終迄繰り返し
  For i = 1 To lngRows
    'Sheet1から1行分配列として取得
    vntData = rngList.Offset(i).Resize(, 4).Value
    '日付をシリアル値に変換
    vntData(1, 3) = GetDate(vntData(1, 3))
    '日付がSheet2の範囲内で
    If vntMin <= vntData(1, 3) And vntData(1, 3) <= vntMax Then
      '品番がSheet2に在るなら
      If dicIndex.Exists(vntData(1, 2)) Then
        '個数を出力用配列に加算
        vntResult(dicIndex.Item(vntData(1, 2)), vntData(1, 3)) _
            = vntResult(dicIndex.Item(vntData(1, 2)), vntData(1, 3)) + vntData(1, 4)
      End If
    End If
  Next i
  
  With rngResult.Offset(1, 1).Resize(UBound(vntResult, 1), vntMax - vntMin + 1)
    '結果範囲を消去
    .ClearContents
    '結果を出力
    .Value = vntResult
  End With

  strProm = "処理が完了しました"
   
Wayout:

  Set dicIndex = Nothing
  Set rngList = Nothing
  Set rngResult = Nothing
   
  MsgBox strProm, vbInformation
     
End Sub

Private Function GetDate(vntValue As Variant) As Variant

  Dim lngPos1 As Long
  Dim lngPos2 As Long
  
  GetDate = -1
  
  lngPos1 = InStr(1, vntValue, "/", vbBinaryCompare)
  If lngPos1 = 0 Then
    Exit Function
  End If
  lngPos2 = InStr(lngPos1 + 1, vntValue, "/", vbBinaryCompare)
  
  GetDate = DateSerial(Val(Mid(vntValue, lngPos2 + 1)) + 2000, _
            Val(Left(vntValue, lngPos1 - 1)), _
            Val(Mid(vntValue, lngPos1 + 1, lngPos2 - lngPos1 - 1)))
  
End Function

【66985】Re:列と行が一致した所にデータを挿入し...
お礼  ひぃちゃん  - 10/10/22(金) 22:32 -

引用なし
パスワード
   わざわざ作っていただきありがとうございます。
今日は出来なかったのですが、月曜日には是非試してみたいと思います。

又、知らない言葉も多々あったので、大変勉強になりました。
調べながらやってみたいと思います。
どうもありがとうございました!!

【66986】Re:列と行が一致した所にデータを挿入し...
発言  kanabun  - 10/10/22(金) 23:21 -

引用なし
パスワード
   ▼ひぃちゃん さん:

こんにちは。
以下は 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

【66987】Re:列と行が一致した所にデータを挿入し...
お礼  ひぃちゃん  - 10/10/23(土) 19:42 -

引用なし
パスワード
   ありがとうございます。
こちらも併せて月曜にやってみたいと思います。

【66991】Re:列と行が一致した所にデータを挿入し...
発言  Hirofumi  - 10/10/24(日) 10:50 -

引用なし
パスワード
   Upしたコードは、元データが多い場合や品目番号の種類が多い場合
結果出力用配列が大きく成る為、元データを1行分づつ読み込んで
リソース優先で処理速度を犠牲にする様に書いて有ります

もし、元データ、品目番号の種類が巨大で無く速度優先にするなら
kanabunさんのコードと同様に、元データを一括して配列に取得し処理します

其の場合は以下の★印を変更して下さい、
kanabunさんのコードと同程度の処理速度に成ると思います
(元のコードの処理時間の7割程度の時間で済むかと思います)

  'Sheet1に就いて
  With rngList
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row, 1).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    '4列分データを配列として取得
    vntData = .Offset(1).Resize(lngRows, 4).Value '★追加
  End With
  
  'Sheet1先頭〜最終迄繰り返し
  For i = 1 To lngRows
    'Sheet1から1行分配列として取得
'    vntData = rngList.Offset(i).Resize(, 4).Value '★削除
    '日付をシリアル値に変換
    vntData(i, 3) = GetDate(vntData(i, 3)) '★1をiに変更
    '日付がSheet2の範囲内で
    If vntMin <= vntData(i, 3) And vntData(i, 3) <= vntMax Then '★1をiに変更
      '品番がSheet2に在るなら
      If dicIndex.Exists(vntData(i, 2)) Then '★1をiに変更
        '個数を出力用配列に加算
        vntResult(dicIndex.Item(vntData(i, 2)), vntData(i, 3)) _
            = vntResult(dicIndex.Item(vntData(i, 2)), vntData(i, 3)) + vntData(i, 4) '★1をiに変更
      End If
    End If
  Next i

【67008】Re:列と行が一致した所にデータを挿入し...
お礼  ひぃちゃん  - 10/10/25(月) 20:16 -

引用なし
パスワード
   お二人ともありがとうございます。
両方とも無事に動かすことが出来ました。

ただ、品目番号がリストの方はマスターと順番が違うので難しかったです。
別シートのマスターを基準に並び替えが私には出来ませんでした。
ちなみにデータ量は万単位です。マスターは2・3千位でしたので、手作業でするのも
難しかったもので。

お二人に教えて頂いたものは、別の似たもので必要でしたので
使わせていただいております。
ありがとうございました。

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