行と列情報を１つのセルにまとめたいです

質問

こんにちは。
現在、「マクロの記憶」で処理していますが、フリーズが多いため質問させてください。

--------------------------------------------------------------

添付画像７行目までのように、データが入力されています。
同じシート内で、データを処理し添付画像11行目以降のように

・0が書かれたセルを削除したいです。
・1と書かれたセルを、同列１行目に書かれた数字（日にち）に置き換えて、B列の年月とまとめて1セルに収めたいです。→年月日を作成したいです。
・左詰めにまとめたいです。

A列：ID番号
B列：年月
C列-AG列：日にち（C1からAG1までは1～31が連続で入力されています。）

・A列のIDがB列の年月ごと1行でまとまっています。
・IDによっては、年月が同じなのにもかかわらず複数行に分かれることがあります。添付画像16,17行目のようなことが起こります。
・IDごとに、複数行存在する場合があります
・IDは昇順です。年月の順番はバラバラです。

例えば、2行目のIDが1000の方は、B2が201908、Q2とR2が1なので
2019年08月15日（20190815）、2019年８月16日（20190816）としたいです。
多い方だと、１行に15個の年月日が表示されています。

--------------------------------------------------------------

分かりにくい部分がありましたらご教示いただけますと幸いです。
お忙しいところ恐縮ですが、何卒宜しくお願いいたします。

回答No.4

imogasi

例データ　　質問画像の通り
c2:AG7の範囲のセルに「１」がところどころ入っている。
その１０行下のセルに結果が出る。
データの行数が多い場合は、＋１０をデータ数の１０単位切り上げ数を足すに改めること。
データは、２０１８年８月の分とする。２か月分の混合はないものとする。
A１２：A17には
1000
1014
1014
1054
1054
1054
を入れておく。（今回は手動ーVBAでもできるが略）
列幅は日付１０ケタ以上の幅にしておく。（今回は手動ーVBAでもできるが略）
＝＝＝＝
標準モジュールに
Sub test01()
Dim cl As Range
c = 2 'その行でこの列からセット開始列
maerow = 1 '直前処理した行
'---
For Each cl In Range("c2:AG7")
If cl.Value = 1 Then '値が１なら
v = DateValue("2018/08/" & Cells(1, cl.Column)) '日付作成
MsgBox maerow & cl.Row
'--
If cl.Row <> maerow Then '直前処理した行と変わったら
c = 2
End If
'--
Cells(cl.Row + 10, c) = v '10行下へセット
c = c + 1 '次は右隣列へセット
maerow = cl.Row
End If
Next
End Sub
＝＝＝＝
実行すると
私の１を入れた状態だと、
1000 2018/8/4 2018/8/7 2018/8/11 　2018/8/14
1014 2018/8/5 2018/8/8
1014 2018/8/2 2018/8/7 2018/8/10
1054 2018/8/7 2018/8/9
1054 2018/8/4 2018/8/10
1054 2018/8/5 2018/8/8
のようになった。
＝＝
質問表題にはエクセルVBAの質問だということを明記のこと。
＞行と列情報を１つのセルにまとめたい
は詳しく読まないとわかりにくい。標題としては、感心しない。
私なら、箇条書き的に、文章で！（これが思考訓練を助けると思う）
（１）１と入ったセルの第１行の日付を
（２）左列から詰めてセルにセットしたい
（３）データのある行が変わると（２）の行も応じて変わる
とでも、したい。
画像だけに頼ってほしくない。
＝＝
上記は、コード行数が少なくて済むような、処理ロジックを使ったつもり。
それだけに、本質問のデータ状態（配置、並びなど）に依存するものだ。
だから質問の小生の誤解や、データのあり様の誤解がないか心配ですが。

回答No.3

masnoske

> ・0が書かれたセルを削除したいです。
マクロでは，あまりこういう事をやらないほうがいいです．
なぜなら，マクロで削除してしまうと元に戻せません．
また，元データが無ければ，マクロが正しく動いたかどうかも確認できません．
なので，別のシートに書き出すほうがいいです．
見たところ，元データと欲しいデータは行数が同じになるようですので，コードも簡単になります．

Sub Macro1()
Dim sh1 As Worksheet, sh2 As Worksheet ' 各シート
Dim rngBase1 As Range, rngBase2 As Range ' 各シートの基準セル
Dim rng As Range
Dim cnt As Long ' Sheet2 のカウンター
Dim i As Long

' 各シートをセット
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")

' Sheet1 の A列 と 1行目を Sheet2 にコピー
sh1.Activate
sh1.Rows("1:1").Copy sh2.Rows("1:1")
sh1.Columns("A:A").Copy sh2.Columns("A:A")
sh1.Range("A1").Activate
Application.CutCopyMode = False

' Sheet2 にデータを作成
sh2.Activate
For Each rngBase1 In Range(sh1.Range("B2"), sh1.Range("B2").End(xlDown))
Set rngBase2 = sh2.Range(rngBase1.Address).Offset(0, -1)
cnt = 0
For i = 1 To 31
If rngBase1.Offset(0, i).Value = 1 Then
cnt = cnt + 1
rngBase2.Offset(0, cnt).Value = 100 * rngBase1.Value + i
End If
Next
Next

Set sh1 = Nothing
Set sh2 = Nothing
Set rngBase1 = Nothing
Set rngBase2 = Nothing
Set rng = Nothing
End Sub

回答No.2

msMike

もう少しマシな添附圖をオネガイしますよ、それじゃ判讀できやしない！

回答No.1

kkkkkm

以下のような感じでいかがですか。B列が単に数値として201908となっているものとした場合はTestを、日付としてある場合にはTest2を

Sub Test()
Dim c As Range
Dim d As Range
Dim mDate As Long, i As Long

For Each c In Range(Cells(2, "A"), Cells(Rows.Count, "A").End(xlUp))
mDate = Cells(c.Row, "B").Value
i = 2
For Each d In Range(Cells(c.Row, "C"), Cells(c.Row, "AG"))
If d.Value <> 0 Then
Cells(c.Row, i).Value = mDate * 100 + Cells(1, d.Column)
i = i + 1
End If
Next
Range(Cells(c.Row, i), Cells(c.Row, "AG")).ClearContents
Next
End Sub

Sub Test2()
Dim c As Range
Dim d As Range
Dim mDate As Date, i As Long

For Each c In Range(Cells(2, "A"), Cells(Rows.Count, "A").End(xlUp))
mDate = Cells(c.Row, "B").Value
i = 2
For Each d In Range(Cells(c.Row, "C"), Cells(c.Row, "AG"))
If d.Value <> 0 Then
Cells(c.Row, i).Value = Format(mDate, "yyyy/mm/" & Cells(1, d.Column))
i = i + 1
End If
Next
Range(Cells(c.Row, i), Cells(c.Row, "AG")).ClearContents
Next
End Sub