Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

15092 / 76734

←次へ　｜　前へ→


	【67125】Re:1週間分毎を出したいのですが

Hirofumi - 10/11/7(日) 13:31 -


	引用なし

	パスワード

後、日別の集計は、処理が幾分遅く成りますが？
今回の週別の集計とコードを揃える事が出来ますので
以下の様にしても善いかも？

以下のコード全てを同じ標準モジュールに記述して下さい
また、出力シートは実情に合わせて下さい

Option Explicit

Public Sub 日別集計()

　　MsgBox AddUp(Worksheets("Sheet1").Range("A1"), _
　　　　　　Worksheets("Sheet2").Range("A1"), 1), vbInformation

End Sub

Public Sub 週別集計()

　　MsgBox AddUp(Worksheets("Sheet1").Range("A1"), _
　　　　　　Worksheets("Sheet3").Range("A1"), 7), vbInformation

End Sub

Private Function AddUp(rngList As Range, rngResult As Range, lngMode As Long) As String

'　集計（日付が文字列タイプ）

　　Dim i As Long
　　Dim lngRows As Long
　　Dim lngColumns As Long
　　Dim lngRow As Long
　　Dim lngColumn As Long
　　Dim vntData As Variant
　　Dim dicIndex As Object
　　Dim vntMax As Variant
　　Dim vntMin As Variant
　　Dim vntResult() As Variant

　　'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
　　　　　　AddUp = .Parent.Name & "データが有りません"
　　　　　　GoTo Wayout
　　　　End If
　　　　'日付先頭、最終を取得
　　　　vntMin = .Offset(, 2).Value2
　　　　vntMax = vntMin + (lngColumns) * lngMode - 1
　　　　'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
　　
　　'結果出力用配列を確保
　　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
　　　　　　AddUp = .Parent.Name & "データが有りません"
　　　　　　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
　　　　　　'日付がどの週に成るかを計算
　　　　　　lngColumn = (vntData(i, 2) - vntMin) \ lngMode
　　　　　　With dicIndex
　　　　　　　　'品番がSheet2に在るなら
　　　　　　　　If .Exists(CStr(vntData(i, 1))) Then
　　　　　　　　　　lngRow = .Item(CStr(vntData(i, 1)))
　　　　　　　　　　'個数を出力用配列に加算
　　　　　　　　　　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

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

　　Set dicIndex = Nothing
　　
End Function

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)), _
　　　　　　　　　　　　Val(Mid(vntValue, lngPos1 + 1, lngPos2 - lngPos1 - 1)))
　　
End Function

0 hits

▼

【67016】別シートにあるデータを基準に並べ替えたい ひぃちゃん 10/10/26(火) 21:40