Excel VBA質問箱 IV

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

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


2577 / 13646 ツリー ←次へ | 前へ→

【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 お礼[未読]

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

引用なし
パスワード
   どうしても出来ないので教えてください。

先日『【66968】列と行が一致した所にデータを挿入したい』で
教えてもらった方法を是非使いたいのでお願い致します。

別シートB列に千行くらいのマスター品目があります。それにあわせて
Sheet1にある2万くらいのデータを並び替えたいです。
マスターは増減することがあるのですが、それはその度にマスターを
呼び出して行えば大丈夫だと思うのですが。

データは順番がバラバラで、品目1つに対して日付と個数が色々あります。

  A列  B列  C列
例)DDD 2/10/11 300
  DDD 2/16/11 250
  AAA 1/13/10 100
  AAA 1/14/10 150

のような感じです。

ユーザー定義なども試してみたのですが駄目でした。
何かいいほうがあれば是非教えてください。

【67017】Re:別シートにあるデータを基準に並べ替...
発言  Hirofumi  - 10/10/26(火) 21:55 -

引用なし
パスワード
   何をどう並べ替えたいのですか?
また、先日『【66968】列と行が一致した所にデータを挿入したい』
のコードで、私のコードもkanabunさんのコードも並べ替えが必要な部分は
無いと思いますが?

【67018】Re:別シートにあるデータを基準に並べ替...
発言  Hirofumi  - 10/10/26(火) 22:06 -

引用なし
パスワード
   後、『【66968】列と行が一致した所にデータを挿入したい』で言っている
Sheet1とSheet2の表のレイアウトが違っている様なので
各レイアウトをキチント示して下さい

【67019】Re:別シートにあるデータを基準に並べ替...
質問  ひぃちゃん  - 10/10/26(火) 22:07 -

引用なし
パスワード
   お世話になります。

先日教えていただいたコードなのですが、
並び替えた場合は(マスターをコピーしてバラバラの上に
貼り付けてみた)上手く表示されるのですが、
バラバラに並んでいる状態だと表示がまったくされませんでした。

その為、ソートが必要なのかと思ってしまいました。
知らない言葉もある為、失礼しました。

データの種類が問題なのでしょうか・・・。

品目番号の桁数が8桁から10桁あるのですが、それは関係あるのでしょうか。

【67020】Re:別シートにあるデータを基準に並べ替...
質問  ひぃちゃん  - 10/10/26(火) 22:19 -

引用なし
パスワード
   お世話になります。
変わった部分は一応手直しして使ってみたのですが。


データ:
A列に品目番号(A1タイトルA2以降データ)
B列に文字列になっている日付(B1タイトルB2以降データ)
C列に数量(C1タイトルC2以降データ)


データ出力先:
A列に品目番号に対応したコード(A1タイトルA2以降)
B列に品目番号(データリストはこの番号を使っています)(B1タイトルB2以降)
C1からの行(90日分の日付)


  A | B | C | D |E
-|--------------------------
1| No|品目 | 1/1 | 1/2 | 1/3
-|--------------------------
2| TR|AAA | 0 | 10 | 3
-|--------------------------
3| AB|BBB | 2 | 1 | 0


このような感じです。
お手数をおかけしますが宜しくお願い致します。

【67021】Re:別シートにあるデータを基準に並べ替...
回答  Hirofumi  - 10/10/26(火) 22:37 -

引用なし
パスワード
   ▼ひぃちゃん さん:
>お世話になります。
>変わった部分は一応手直しして使ってみたのですが。
>
>
>データ:
>A列に品目番号(A1タイトルA2以降データ)
>B列に文字列になっている日付(B1タイトルB2以降データ)
>C列に数量(C1タイトルC2以降データ)
>
>
>データ出力先:
>A列に品目番号に対応したコード(A1タイトルA2以降)
>B列に品目番号(データリストはこの番号を使っています)(B1タイトルB2以降)
>C1からの行(90日分の日付)
>
>
>  A | B | C | D |E
>-|--------------------------
>1| No|品目 | 1/1 | 1/2 | 1/3
>-|--------------------------
>2| TR|AAA | 0 | 10 | 3
>-|--------------------------
>3| AB|BBB | 2 | 1 | 0
>
>
>このような感じです。
>お手数をおかけしますが宜しくお願い致します。

これが、本当のレイアウトでこの上で前回のコードを動かしても
レイアウトが違うので動きませんよ

コードを修正してからUpします

【67022】Re:別シートにあるデータを基準に並べ替...
回答  Hirofumi  - 10/10/26(火) 22:59 -

引用なし
パスワード
   データシートはSheet1に在る物とします(ひぃちゃん さんのシート名にして下さい)
データ出力先はSheet2とします(ひぃちゃん さんのシート名にして下さい)
データ出力先のB列の値とデータシートのA列の値を比較します
データ出力先の日付は、C1を先頭として90日間とします
データ出力先のC1の日付はシリアル値(日付連番)とします

因みに、前回の質問では、
>Sheet1に A1にタイトル、B1に品目番号、C1に日付、D1個数があります。
>Sheet2にマスターとしてA列に品目番号、1行目に日付があります。
と成っていましたの、レイアウトが違う為、上手く動きません

Option Explicit

Public Sub Sample_3()

  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, 1).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    '日付先頭、最終を取得
    vntMin = .Offset(, 2).Value2
    vntMax = vntMin + 90 - 1
    'B列データを配列として取得
    vntData = .Offset(1, 1).Resize(lngRows + 1).Value
    'B列データを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
    '4列分データを配列として取得
    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
      '品番がSheet2に在るなら
      If dicIndex.Exists(vntData(i, 1)) Then
        '個数を出力用配列に加算
        vntResult(dicIndex.Item(vntData(i, 1)), vntData(i, 2)) _
            = vntResult(dicIndex.Item(vntData(i, 1)), vntData(i, 2)) + vntData(i, 3)
      End If
    End If
  Next i
  
  With rngResult.Offset(1, 2).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)
  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

【67023】Re:別シートにあるデータを基準に並べ替...
発言  ひぃちゃん  - 10/10/26(火) 23:04 -

引用なし
パスワード
   ▼Hirofumi さん:
ありがとうございます。
素人的な考えでやって、お恥ずかしい限りです。
明日早速組み込んでみたいと思います。
又結果を明日連絡させてください。
ありがとうございました。

【67032】お礼と質問です。
お礼  ひぃちゃん  - 10/10/27(水) 20:29 -

引用なし
パスワード
   お世話になります。
無事に動かすことが出来ました。
レイアウトの他に、データとマスターに文字列と数値が混ざっていた為
上手く出力されなかったようです。
それに気づくまで時間がかかりましたが無事に動かせました。
ありがとうございました。

後、もう1つ宜しかったら教えてください。
連続の日にちではなく、バラバラの日付を出力するにはどうしたらいいでしょうか。
90-1の辺りを触ってみたのですがうまく行きません。

月ごとの出力が出来ればと。
20○○年の1/1・2/1・3/1・・・と言うように
6か月分6列を出力したいと思ってます。
合計は先日教えていただいたものに使ったデータを
ピボットで計算して月ごとにまとめています。

列の非表示・表示で対応しようとしたのですが出来ませんでした。

レイアウトは全く同じです。
是非よろしくお願い致します。

【67033】Re:お礼と質問です。
回答  Hirofumi  - 10/10/27(水) 22:08 -

引用なし
パスワード
   >後、もう1つ宜しかったら教えてください。
>連続の日にちではなく、バラバラの日付を出力するにはどうしたらいいでしょうか。
>90-1の辺りを触ってみたのですがうまく行きません。
>
>月ごとの出力が出来ればと。
>20○○年の1/1・2/1・3/1・・・と言うように
>6か月分6列を出力したいと思ってます。
>合計は先日教えていただいたものに使ったデータを
>ピボットで計算して月ごとにまとめています。
>
>列の非表示・表示で対応しようとしたのですが出来ませんでした。
>
>レイアウトは全く同じです。
>是非よろしくお願い致します。

1、バラバラの日付とは如何言う事でしょうか?
 現在のコードでは、日付は連続している事が前提ですが?
 品番にDictionaryオブジェクトを使用しているので、
 コードを変更すれば、日付側も同じ、Dictionaryオブジェクトで
 探索する事は可能です
2、「月ごとの出力が出来ればと。20○○年の1/1・2/1・3/1・・・と言うように」
 とは、20○○年の1/1だけと言う意味ですか?
 それとも、20○○年の1/1は1月の1カ月分全てを加算した値ですか?

そこいら辺をレイアウトを含めてもう少し詳しく説明して頂ければありがたいのですが?

【67034】Re:お礼と質問です。
質問  ひぃちゃん  - 10/10/27(水) 22:42 -

引用なし
パスワード
   >1、バラバラの日付とは如何言う事でしょうか?

ばらばらの日付と言うのはHirofumiさんが下記に書かれている月のものことです。
                         ↓
>2、「月ごとの出力が出来ればと。20○○年の1/1・2/1・3/1・・・と言うように」
> とは、20○○年の1/1だけと言う意味ですか?


出力レイアウトは日付以外は全く同じです。
C1が例えば1/1(20○○年1月1日のこと)で次のセルが月で連続しています。
例)20○○年の1/1・2/1・3/1・・・と言う感じで6列分(6ヶ月)を表したいです。

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


データ出力先:
A列に品目番号に対応したコード(A1タイトルA2以降)
B列に品目番号(データリストはこの番号を使っています)(B1タイトルB2以降)
C1からの行(1月・2月・・・という6ヶ月の日付)


  A | B | C | D |E
-|--------------------------
1| No|品目 | 1/1 | 2/1 | 3/1
-|--------------------------
2| TR|AAA | 0 | 10 | 3
-|--------------------------
3| AB|BBB | 2 | 1 | 0


> それとも、20○○年の1/1は1月の1カ月分全てを加算した値ですか?

前回のデータを月ごとに合計したものです。
ピボットで例えば1月のものは1/1に変更して無理矢理合算していますが、
前回のデータを月ごとに合計し表示できるのであればそのようにしたいです。

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

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

引用なし
パスワード
   データシートはSheet1に在る物とします(ひぃちゃん さんのシート名にして下さい)
データシートのB列の日付は文字列ではありません 例)2010/1/1(B1タイトルB2以降データ)
データ出力先はSheet2とします(ひぃちゃん さんのシート名にして下さい)
データ出力先のB列の値とデータシートのA列の値を比較します
データ出力先のC1の日付はシリアル値(日付連番)とします
データ出力先の日付は、C1を先頭として値は月の1日とします(例「2010/10/1」でセル書式は何でも可)
データ出力先の日付は、最終列を検出しているので、6ヵ月で無くても可
連続した月なら3ヵ月でも12ヵ月でも、C1〜最終列迄の列数=月数と成ります

尚、データシートのB列の日付はコード上で月の1日と変換します
多分大丈夫だと思いますが?、データシート、データ出力先の品番はコード上で全て文字列として扱います

Option Explicit

Public Sub Sample_4()

'  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
    '日付を月の1日に変換
    vntData(i, 2) = DateSerial(Year(vntData(i, 2)), Month(vntData(i, 2)), 1)
    '日付が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

【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

【67045】Re:お礼と質問です。
お礼  ひぃちゃん  - 10/10/28(木) 21:09 -

引用なし
パスワード
   ▼Hirofumi さん:

>前回と同じデータを使用したいと言う事は
>B列が文字列の「5/18/10」形式と言う子ですか?
>其れなら、コードを以下とします
はい、そうです。
無事に2つともに組み込むことが出来ました。
Dictionaryオブジェクトは是非勉強したいと思いました。
本当にありがとうございました。

【67119】1週間分毎を出したいのですが
質問  ひぃちゃん  - 10/11/6(土) 22:03 -

引用なし
パスワード
   お世話になります。
新たに1週間分毎の集計も必要と言われ、自分で色々やってみましたが
やはりうまく行きません。

Sheet2の先頭の日付から7日間毎の集計を何週か分か出したいのですが
可能でしょうか?(月毎のと同じように1W・2Wとだしたいです)

お手数をおかけ致しますが、どうぞ教えてください。
よろしくお願い致します。

【67120】Re:1週間分毎を出したいのですが
発言  Hirofumi  - 10/11/6(土) 23:49 -

引用なし
パスワード
   ひぃちゃん さん:
>お世話になります。
>新たに1週間分毎の集計も必要と言われ、自分で色々やってみましたが
>やはりうまく行きません。
>
>Sheet2の先頭の日付から7日間毎の集計を何週か分か出したいのですが
>可能でしょうか?(月毎のと同じように1W・2Wとだしたいです)
>
>お手数をおかけ致しますが、どうぞ教えてください。
>よろしくお願い致します。

これ、集計自体は可能なのですが?
集計期間で1W、2Wが何日〜何日に成るのか?を
集計表の何処に、書いて置くかが問題ですね?

【67121】Re:1週間分毎を出したいのですが
回答  Hirofumi  - 10/11/7(日) 1:07 -

引用なし
パスワード
   一応、こんな形で作って見ました

Sheet2(集計表)のC1(集計先頭日付セル)に例えば「2010/10/3」と入力します
セル書式を「m/d"〜"」とし、左詰めにしますとセルは「10/3〜 」と成ります
次にD1は、「=C1+7」として、セル書式を「m/d"〜"」とします、此れを集計週分右にCopyします
またA列、B列は前回と同様にNo、コードを入れて置きます
日付は前回の文字列型とします

上記の表が作られているのを前提にして

Option Explicit

Public Sub Sample_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
    vntMax = vntMin + (lngColumns - 1) * 7
    '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
      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
      '日付がどの週に成るかを計算
      lngColumn = (vntData(i, 2) - vntMin) \ 7
      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

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

【67122】Re:1週間分毎を出したいのですが
回答  Hirofumi  - 10/11/7(日) 1:16 -

引用なし
パスワード
   vntMaxの計算を間違えた、以下の★印に変更して下さい

    '日付先頭、最終を取得
    vntMin = .Offset(, 2).Value2
'    vntMax = vntMin + (lngColumns - 1) * 7
    vntMax = vntMin + (lngColumns) * 7 - 1 '★変更

【67124】Re:1週間分毎を出したいのですが
お礼  ひぃちゃん  - 10/11/7(日) 13:18 -

引用なし
パスワード
   お返事が遅くなってすみません。
集計はピボットを使おうとして詰まっていました。
月曜日に早速使ってみたいと思います。
何度もありがとうございました。
本当に助かりました。

【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

【67142】Re:1週間分毎を出したいのですが
お礼  ひぃちゃん  - 10/11/9(火) 20:22 -

引用なし
パスワード
   ありがとうございました。
無事組み込むことが出来ました。
大変助かりました。
速度も申し分ないです。

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