ＶＢＡ 表作成 続続

質問

以前何度もこの「ＶＢＡ表作成」というタイトルで何度か質問させていただきました。
前回の締め切りのあと何度もデバック？やってみながら訂正してみたりしたのですが出来ませんでした。
☆詳細（仕様？）
・入力フォームブックで日付を入力すると出力ブックに入力した日付から１ヶ月の日付が表示されます。
・入力データブックがあり入力フォームで入力した日付から１ヶ月の日付で入力データにあるデータを貼り付けます。
・重複したデータは足して表示させます。
☆入力データブック
・Ｂ列に日付：日付の下に曜日が表示されています。
・Ｍ列に区分：１か２が書いてあります。
・Ｔ列に商品名：結合は関係ないとは思いますが、ＴからＡＰまで結合されています。
・ＡＱ列に数量：ＡＱからＡＵまで結合されています。
・ＢＡ列にコード：表示上記４つに比べ１行下に表記されていてＢＡからＢＤまで結合されています。
☆出力ブック
・ＢからＨまで結合されており、Ｂ６に商品名が表示されます。（現時点では商品１つ分しかないので増えるたびに１行ずつセルが結合され挿入されます
・ＩからＫまで結合されており、Ｉ６にコードが表示されます。（これも上記と同じ）
・６行目～→区分１の場合・８行目～→区分２の場合に表示します。

(1)出力ブック（以下book）の表は品名とコードを表示する部分が結合されているのですが、挿入され別の値が表示となったときに結合されておらず、コードも表示されませんでした。
(2)入らないはずの所に数値が入ってしまいます。
(3)入るはずの所に値が表示されません（８行目以降の欄）

・品名：Ｂ５からＨ５まで結合されています。
品名が表示されるのはＢ６からＨ６までで挿入されるときも結合されて表示されたいです。
・コード：Ｉ５からＫ５まで結合されています。
コードが表示されるのはＩ６からＩ６までで挿入されるときも結合されて表示されたいです。

Sub Get_nyuryoku(wDate As String, hNm As String, hCd As String, hKbn As String, s As Integer)

Dim wData As Worksheet
Dim i As Integer
Dim mR As Long

Set wData = Workbooks("入力データ.xls").Worksheets("Sheet1")

With wData
mR = .Cells(Rows.Count, "B").End(xlUp).Row
For i = 3 To mR
If .Cells(i, "B") = wDate Then '←ここで両方の日付を確認
hNm = .Cells(i, "T")　　←商品名
hCd = .Cells(i, "BA")　←コード
hKbn = .Cells(i, "M")　←区分
s = .Cells(i, "AQ")　　←数量
Exit For
End If
Next
End With
End Sub

お手数掛けますがよろしくおねがいします。

他に書かなきゃいけないことがありましたら言ってください。

回答No.1

pkh4989 · ベストアンサー

こんにちは。
以下の点について教えてください。
(1) 入力データブック上に日付が表示上と実際入力されている内容が同じなのか
　 →日付表ブックには、表示は「mm/dd」、実際入力情報としては「yyyy/mm/dd」です。
(2) 入力データブック上の日付は同じ日付が複数存在するのか。
　 →複数存在するなら、検索して加算処理が必要

後、セル追加処理時、セルの結合は行ってない「そこまでは知りませんでした」
入力データブックの日付入力形式が、多分文字列ではないでしょう
→文字列ではないと、Find では検索できないので、わざと、Forで回したのです。
　Find を使えば簡単なんだけど・・・

取りあえず、セルの結合処理を追加しましたので、試してみてください。
どうしても、分からない場合は、現在のソース全てを提示くさい。

'商品情報の編集
Sub Edit_Shouhin(wSh2 As Worksheet)
　　Dim wC　　　　　As Integer
　　Dim mC　　　　　As Integer
　　Dim wDate　　　 As String
　　Dim hNm　　　　 As String
　　Dim hCd　　　　 As String
　　Dim hKbn　　　　As String
　　Dim hSu　　　　 As Integer
　　Dim sTot1　　　 As Integer
　　Dim sTot2　　　 As Integer
　　Dim aSum　　　　As Integer
　　Dim Kbn1　　　　As Integer
　　Dim Kbn2　　　　As Integer
　　Dim wI　　　　　As Integer
　　Dim fflg　　　　As Boolean
　　Dim wSu　　　　 As Integer
　　'
　　sTot1 = 7: sTot2 = 9: aSum = 10
　　Kbn1 = 6: Kbn2 = 8
　　With wSh2
　　　　mC = .Cells(5, 12).End(xlToRight).Column
　　　　For wC = 12 To mC
　　　　　　wDate = wSh2.Cells(4, wC)
　　　　　　'商品情報取得
　　　　　　hNm = "": hCd = "": hKbn = "": hSu = 0　　　'★←追加
　　　　　　Call Get_HinData(wDate, hNm, hCd, hKbn, hSu)
　　　　　　Select Case hKbn
　　　　　　　　Case "1"　　'区分1
　　　　　　　　　　If .Cells(6, "B") = "" Then
　　　　　　　　　　　　.Cells(6, "B") = hNm　　　　　　'商品名
　　　　　　　　　　　　.Cells(6, "I") = hCd　　　　　　'商品コード
　　　　　　　　　　　　.Cells(6, wC) = hSu　　　　　　 '数量
　　　　　　　　　　Else
　　　　　　　　　　　　fflg = False
　　　　　　　　　　　　For wI = 6 To Kbn1
　　　　　　　　　　　　　　If .Cells(wI, "B") = hNm Then
　　　　　　　　　　　　　　　　.Cells(wI, wC) = hSu　　'数量
　　　　　　　　　　　　　　　　fflg = True
　　　　　　　　　　　　　　　　Exit For
　　　　　　　　　　　　　　End If
　　　　　　　　　　　　Next
　　　　　　　　　　　　If fflg = False Then
　　　　　　　　　　　　　　'行の追加
　　　　　　　　　　　　　　.Rows(sTot1).Insert Shift:=xlDown
　　　　　　　　　　　　　　'セル結合
　　　　　　　　　　　　　　Range("B" & sTot1 & ":H" & sTot1).MergeCells = True '★←追加
　　　　　　　　　　　　　　Range("I" & sTot1 & ":K" & sTot1).MergeCells = True '★←追加
　　　　　　　　　　　　　　.Cells(sTot1, "B") = hNm　　'商品名
　　　　　　　　　　　　　　.Cells(sTot1, "I") = hCd　　'商品コード
　　　　　　　　　　　　　　.Cells(sTot1, wC) = hSu　　 '数量
　　　　　　　　　　　　　　Kbn1 = Kbn1 + 1
　　　　　　　　　　　　　　Kbn2 = Kbn2 + 1
　　　　　　　　　　　　　　sTot1 = sTot1 + 1
　　　　　　　　　　　　　　sTot2 = sTot2 + 1
　　　　　　　　　　　　　　aSum = aSum + 1
　　　　　　　　　　　　End If
　　　　　　　　　　End If
　　　　　　　　Case "2"　　'区分2
　　　　　　　　　　If .Cells(Kbn1 + 2, "B") = "" Then
　　　　　　　　　　　　.Cells(Kbn1 + 2, "B") = hNm　　 '商品名
　　　　　　　　　　　　.Cells(Kbn1 + 2, "I") = hCd　　 '商品コード
　　　　　　　　　　　　.Cells(Kbn1 + 2, wC) = hSu　　　'数量
　　　　　　　　　　Else
　　　　　　　　　　　　For wI = Kbn1 + 2 To Kbn2
　　　　　　　　　　　　　　If .Cells(wI, "B") = hNm Then
　　　　　　　　　　　　　　　　.Cells(wI, wC) = hSu　　'数量
　　　　　　　　　　　　　　　　fflg = True
　　　　　　　　　　　　　　　　Exit For
　　　　　　　　　　　　　　End If
　　　　　　　　　　　　Next
　　　　　　　　　　　　If fflg = False Then
　　　　　　　　　　　　　　'行の追加
　　　　　　　　　　　　　　.Rows(sTot2).Insert Shift:=xlDown
　　　　　　　　　　　　　　'セル結合
　　　　　　　　　　　　　　Range("B" & sTot2 & ":H" & sTot2).MergeCells = True '★←追加
　　　　　　　　　　　　　　Range("I" & sTot2 & ":K" & sTot2).MergeCells = True '★←追加
　　　　　　　　　　　　　　.Cells(sTot2, "B") = hNm　　'商品名
　　　　　　　　　　　　　　.Cells(sTot2, "I") = hCd　　'商品コード
　　　　　　　　　　　　　　.Cells(sTot2, wC) = hSu　　 '数量
　　　　　　　　　　　　　　Kbn2 = Kbn2 + 1
　　　　　　　　　　　　　　sTot2 = sTot2 + 1
　　　　　　　　　　　　　　aSum = aSum + 1
　　　　　　　　　　　　End If
　　　　　　　　　　End If
　　　　　　End Select
　　　　Next
　　　　'
　　　　'小計設定(区分1)
　　　　For wC = 12 To mC
　　　　　　wSu = 0
　　　　　　For wI = 6 To Kbn1
　　　　　　　　wSu = wSu + .Cells(wI, wC)
　　　　　　Next
　　　　　　.Cells(sTot1, wC) = wSu
　　　　Next
　　　　'小計設定(区分2)
　　　　For wC = 12 To mC
　　　　　　wSu = 0
　　　　　　For wI = Kbn1 + 2 To Kbn2
　　　　　　　　wSu = wSu + .Cells(wI, wC)
　　　　　　Next
　　　　　　.Cells(sTot2, wC) = wSu
　　　　Next
　　　　'合計設定
　　　　For wC = 12 To mC
　　　　　　wSu = .Cells(sTot1, wC) + .Cells(sTot2, wC)
　　　　　　.Cells(aSum, wC) = wSu
　　　　Next
　　End With
End Sub
'商品情報取得
Sub Get_HinData(wDate As String, hNm As String, hCd As String, hKbn As String, hSu As Integer)
　　Dim wData　　　 As Worksheet
　　Dim wI　　　　　As Integer
　　Dim c　　　　　 As Range
　　'
　　Set wData = Workbooks("入力データ.xls").Worksheets("Sheet2")　'←実際のブック名とシート名に変更
　　With wData
　　　　mR = .Cells(Rows.Count, "B").End(xlUp).Row
　　　　'Set c = .Range("B3:B" & mR).Find(wDate)
　　　　'If Not c Is Nothing Then
　　　　'　　hNm = .Cells(c.Row, "T")
　　　　'　　hCd = .Cells(c.Row, "BA")
　　　　'　　hKbn = .Cells(c.Row, "M")
　　　　'　　hSu = .Cells(c.Row, "AQ")
　　　　'End If
　　　　For wI = 3 To mR
　　　　　　If .Cells(wI, "B") = wDate Then　　　　 '←ここで両方の日付を確認してください
　　　　　　　　hNm = .Cells(wI, "T")
　　　　　　　　hCd = .Cells(wI, "BA")
　　　　　　　　hKbn = .Cells(wI, "M")
　　　　　　　　hSu = .Cells(wI, "AQ")
　　　　　　　　Exit For
　　　　　　End If
　　　　Next
　　End With
End Sub

補足

こんにちわ。
何度もすみません。
>(1) 入力データブック上に日付が表示上と実際入力されている内容が同じなのか
　 →日付表ブックには、表示は「mm/dd」、実際入力情報としては「yyyy/mm/dd」です
違います；；入力は「yyyy/mm/dd」で表は「mm/dd」で入力データは「mm/dd」になります
>(2) 入力データブック上の日付は同じ日付が複数存在するのか。
　 →複数存在するなら、検索して加算処理が必要
同じ日付が複数存在しています。

数値は一箇所だけになりましたが結合がされてませんでした；；

よろしくお願いします。

回答No.3

pkh4989

(1)
>区分１の方はできていたのですが変更したら区分２のコードと数値のみが表示されました。
不具合内容とか、出来ない部分の内容を具体的に言わないと分かりませんよ
→商品名が表示されないなら、検索の方から商品名が設定されて来るのか確認、
　 あるいは、設定したのに表示されないとか「この場合は設定セル位置の問題だと思うので
　　　設定セルを正しく修正すれば良いでしょう」

(2)
>現在のソースは変更したところでいいですか？
全体のソースを提示しないと、何処が悪いのか分かりません。(ソースの一部では判断出来ない)

とにかく、自分で解決してみてくださいね。
全体のソース提示は、駄目な場合です。

お礼

すみません！！
できました！！
初期化するソースの場所と配列を使ってみたら同じ日付でも表示することができました！！

ありがとうございました

補足

貼り付けたいのですが全て貼り付けできません。

回答No.2

pkh4989

以下の★マーク部分を変更してください。
後、正しく動作しない部分がありましたら、自分で修正してみてくださいね。
どうしても、分からない時は、現在のソースそのまま提示してください。

商品情報取得
Sub Get_HinData(wDate As String, hNm As String, hCd As String, hKbn As String, hSu As Integer)
　Dim wData　　As Worksheet
　Dim wI　　　As Integer
　Dim c　　　As Range
　'
　Set wData = Workbooks("入力データ.xls").Worksheets("Sheet2")　'←実際のブック名とシート名に変更
　With wData
　　mR = .Cells(Rows.Count, "B").End(xlUp).Row
　　For wI = 3 To mR
　　　If Format(.Cells(wI, "B"),"mm/dd") = Format(wDate,"mm/dd") Then　'←★変更
　　　　hNm = .Cells(wI, "T")
　　　　hCd = .Cells(wI, "BA")
　　　　hKbn = .Cells(wI, "M")
　　　　hSu = hSu + .Cells(wI, "AQ")　　　 '←★変更
　　　　　　　　'Exit For　　　　　　　　　　　　　'←★変更(削除)
　　　End If
　　Next
　End With
End Sub

補足

ありがとうございます。
区分１の方はできていたのですが変更したら区分２のコードと数値のみが表示されました。
現在のソースは変更したところでいいですか？

'商品情報取得
Sub Get_nyuryoku(wDate As String, hNm As String, hCd As String, hKbn As String, s As Integer)

Dim wData As Worksheet
Dim i As Integer
Dim mR As Long

Set wData = Workbooks("入力データ.xls").Worksheets("Sheet1")

With wData
mR = .Cells(Rows.Count, "B").End(xlUp).Row
For i = 3 To mR
If Format(.Cells(i, "B"), "m/d") = Format(wDate, "m/d") Then '両方の日付を確認
hNm = .Cells(i, "T")
hCd = .Cells(i + 1, "BA")
hKbn = .Cells(i, "M")
s = s + .Cells(i, "AQ")
Exit For
End If
Next
End With
End Sub

これが今のソースです。