Excel VBA質問箱 IV

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

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


15180 / 76734 ←次へ | 前へ→

【67036】Re:お礼と質問です。
回答  Hirofumi  - 10/10/27(水) 23:51 -

引用なし
パスワード
   >データ:今回無理矢理加工して使用しているデータ
>   (前回のデータを月毎に合計し使用できるなら前回のを使用したいです)
>A列に品目番号(A1タイトルA2以降データ)
>B列に日付 文字列ではありません 例)2010/1/1(B1タイトルB2以降データ)
>C列に数量(C1タイトルC2以降データ)

前回と同じデータを使用したいと言う事は
B列が文字列の「5/18/10」形式と言う子ですか?
其れなら、コードを以下とします

Option Explicit

Public Sub Sample_5()

'  6ヵ月集計(日付が文字列タイプ)

  Dim i As Long
  Dim lngRows As Long
  Dim lngColumns As Long
  Dim lngRow As Long
  Dim lngColumn 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, 1).End(xlUp).Row - .Row
    lngColumns = .Offset(, Columns.Count - .Column).End(xlToLeft).Column - .Column + 1
    lngColumns = lngColumns - 2
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    '日付先頭、最終を取得
    vntMin = .Offset(, 2).Value2
    vntMin = DateSerial(Year(vntMin), Month(vntMin), 1)
    vntMax = DateSerial(Year(vntMin), Month(vntMin) + lngColumns - 1, 1)
    '日付列をDictionaryに登録
    For i = 0 To lngColumns - 1
      dicIndex.Item(Format(DateSerial(Year(vntMin), Month(vntMin) + i, 1), "yyyy/m/d")) = i
    Next i
    'B列データを配列として取得
    vntData = .Offset(1, 1).Resize(lngRows + 1).Value
    'B列データをDictionaryに登録
    For i = 1 To lngRows
      dicIndex.Item(CStr(vntData(i, 1))) = i
    Next i
  End With
  
  '結果出力用配列を確保(2次元目は日付のシリアル値と同じにして置く)
  ReDim vntResult(1 To lngRows, 0 To lngColumns - 1)
  
  'Sheet1に就いて
  With rngList
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row, 1).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    '3列分データを配列として取得
    vntData = .Offset(1).Resize(lngRows, 3).Value
  End With
  
  'Sheet1先頭〜最終迄繰り返し
  For i = 1 To lngRows
    '日付をシリアル値に変換
    vntData(i, 2) = GetDate(vntData(i, 2))
    '日付がSheet2の範囲内で
    If vntMin <= vntData(i, 2) And vntData(i, 2) <= vntMax Then
      With dicIndex
        '品番がSheet2に在るなら
        If .Exists(CStr(vntData(i, 1))) Then
          lngRow = .Item(CStr(vntData(i, 1)))
          lngColumn = .Item(Format(vntData(i, 2), "yyyy/m/d"))
          '個数を出力用配列に加算
          vntResult(lngRow, lngColumn) = vntResult(lngRow, lngColumn) + vntData(i, 3)
        End If
      End With
    End If
  Next i
  
  With rngResult.Offset(1, 2).Resize(UBound(vntResult, 1), lngColumns)
    '結果範囲を消去
    .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)
  If lngPos2 = 0 Then
    Exit Function
  End If
  
  GetDate = DateSerial(Val(Mid(vntValue, lngPos2 + 1)) + 2000, _
            Val(Left(vntValue, lngPos1 - 1)), 1)
  
End Function

0 hits

【67016】別シートにあるデータを基準に並べ替えたい ひぃちゃん 10/10/26(火) 21:40 質問
【67017】Re:別シートにあるデータを基準に並べ替え... Hirofumi 10/10/26(火) 21:55 発言
【67018】Re:別シートにあるデータを基準に並べ替え... Hirofumi 10/10/26(火) 22:06 発言
【67020】Re:別シートにあるデータを基準に並べ替え... ひぃちゃん 10/10/26(火) 22:19 質問
【67021】Re:別シートにあるデータを基準に並べ替え... Hirofumi 10/10/26(火) 22:37 回答
【67022】Re:別シートにあるデータを基準に並べ替え... Hirofumi 10/10/26(火) 22:59 回答
【67023】Re:別シートにあるデータを基準に並べ替え... ひぃちゃん 10/10/26(火) 23:04 発言
【67032】お礼と質問です。 ひぃちゃん 10/10/27(水) 20:29 お礼
【67033】Re:お礼と質問です。 Hirofumi 10/10/27(水) 22:08 回答
【67034】Re:お礼と質問です。 ひぃちゃん 10/10/27(水) 22:42 質問
【67035】Re:お礼と質問です。 Hirofumi 10/10/27(水) 23:38 回答
【67036】Re:お礼と質問です。 Hirofumi 10/10/27(水) 23:51 回答
【67045】Re:お礼と質問です。 ひぃちゃん 10/10/28(木) 21:09 お礼
【67019】Re:別シートにあるデータを基準に並べ替え... ひぃちゃん 10/10/26(火) 22:07 質問
【67119】1週間分毎を出したいのですが ひぃちゃん 10/11/6(土) 22:03 質問
【67120】Re:1週間分毎を出したいのですが Hirofumi 10/11/6(土) 23:49 発言
【67121】Re:1週間分毎を出したいのですが Hirofumi 10/11/7(日) 1:07 回答
【67122】Re:1週間分毎を出したいのですが Hirofumi 10/11/7(日) 1:16 回答
【67124】Re:1週間分毎を出したいのですが ひぃちゃん 10/11/7(日) 13:18 お礼
【67125】Re:1週間分毎を出したいのですが Hirofumi 10/11/7(日) 13:31 回答
【67142】Re:1週間分毎を出したいのですが ひぃちゃん 10/11/9(火) 20:22 お礼

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