マクロ データ加工 番号に合わせて行を挿入し移動

質問

添付の左の状態から右の状態に加工するマクロが知りたいです。

A列：A7から１~18まで番号、空白1行、１~18まで番号、空白1行…繰り返し
左のB列：B１のみ見出し、B2からタイトル、１~いずれかのの番号（９だったり16だったりいろいろ）、タイトル、１~いずれかのの番号、タイトル…繰り返し
左のC列とD列：B列の番号に該当する氏名と生年月日

右の状態にするには最初の1~4行を下げる、赤の番号と黒の番号を合致するように移動し、黒の番号がないときはその行を18まで空白行にする、タイトル、番号を合わせて移動…という繰り返しになります。（黄色の部分を空白行にして調整）
この手順でなくても結果が同じになれば良いです。

黒の番号は通常は連番ですが、まれに途中の番号がぬけている（例１、２、３、６、７）場合がありますが、その際には抜けている行（例４、５）を空白行にしてもらえると助かります。

回答No.7

Nouble

失敗する、元データが
無いと
検証、しようが
ない、ので
何処の、WEBか
教えて、頂けますか？

補足

WEBデータをあるソフトを使って取り込んだものですので、Webのものとはまた違っています。1つ目の18個はできるのに、2つ目以降ができないというのは何か思い当りませんか？

回答No.6

Nouble

一応
情報使用許諾に、ついての
補足を、お願いします

因みに
コピー元.Copy　コピー先
と、して
セルを、コピー
するだけ
です

補足

こちらのデータはWebに公開されている情報を取り込んでいます。それが毎日のようにこの処理をして仕事をしていますので、コピーの件についても、マクロに取り込んですべて一度にやってしまいたいわけです。

回答No.5

Nouble

あぁ、其れと
今回は
大量の、個人情報を
取り扱いに、なられる
と、思いますが

其の、名簿中の
全員から
情報、使用許諾は
頂かれて、いますか？

此処、最重要点です！！

補足

やっぱり、ダメですね。生年月日の形式を変えても、1つ目の18まではうまくいきますが、２つめからはやっぱり詰まって入力されてしまいます。

回答No.4

Nouble

判りました
失礼しました、済みません

開始位置は
　With　ActiveSheet
　Let　Point1　=　2
　Let　Point3　=　16
と、ある
此処の、point3の
初期値を
16から、7に、
変える、だけ
なので
簡単に、変えれますし、

見出しの、写しも
コピー、するだけ
なので
簡単ですし、

何なら
赤字の、写しも
簡単ですから、

此等は、楽ですが

実際のデータでは動かない
と、なると
何等かの
形質的な、違いが
データ側に、あるもの
と、思います

実データは、流石に
明かせなくて、当然
で、しょうが

同様に
思わしく、行かない
ダミーデータを
お作り頂き

また、新たに
示して、頂けないで
しょうか？

今回の、データでは
上手く、行く
以上
デバッグの、難易度が
上がって、しまいます
ので

まだ
お求め、頂ける
なら
是非とも、お願いします

お礼

試しに元のデータを1999年1月1日という形式に変えたら、できました。でも元のデータをいちいち毎回変えるのは面倒です。数字8桁に対応するようにしたいです。あと、見出しのコピーはどうなりますか？　すみませんが、よろしくお願いいたします。

補足

テストファイルと実際のファイルが違うところは特にないです。氏名は生年月日は19990101と8桁で入力しています。

回答No.3

Nouble

マクロ付き、テストファイルも
良かったら、どうぞ
https://1drv.ms/x/s!AjviygfJDgV_1QZhdZtSEMHyOBTJ

回答No.2

Nouble

勘を、頼りに
作って、みました。

色つけは、してませんが
条件書式で、十分かな？
と、ね

かなり、汚いですが
取りあえずは、動く
と、思います。

あぁ！
そうそう
赤字カウントは
動かして、いません

元々、ある
前提です
変えるのは、簡単です。

Option　Explicit
Option　Base　0

Sub　main()
Dim　カウント2　As　Long,　カウント1　As　Long,　Point1　As　Long,　Point2　As　Long,　Point3　As　Long,　行数　As　Long,　エンド行　As　Long

　With　ActiveSheet
　Let　Point1　=　2
　Let　Point3　=　16
　Let　エンド行　=　.Cells(2,　2).End(xlDown).Row
　Do
　　Let　Point2　=　.Cells(Point1　+　1,　3).End(xlDown).Row
　　Let　行数　=　Point2　-　Point1
　　.Range(.Cells(Point1,　2),　.Cells(Point2,　4)).Copy　.Cells(Point3,　9).Resize(Point2　-　Point1　+　1,　3)
　　If　.Cells(Point3,　9).Offset(Point2　-　Point1,　0).Value　>　行数　_
　　Then
　　For　カウント1　=　1　To　.Cells(Point3,　9).Offset(Point2　-　Point1,　0).Value
　　　If　カウント1　<>　Cells(Point3,　9).Offset(カウント1,　0).Value　_
　　　Then
　　　For　カウント2　=　カウント1　To　.Cells(Point3,　9).Offset(カウント1,　0).Value　-　1
　　　　Call　項分離(.Range(.Cells(Point3　+　カウント2,　9),　.Cells(Point3　+　カウント2,　12)))
　　　Next　カウント2
　　　End　If
　　Next　カウント1
　　End　If
　　Let　Point1　=　Point2　+　1
　　Let　Point3　=　Point3　+　19
　Loop　Until　エンド行　<　Point1
　End　With
End　Sub

Sub　項分離(ByRef　レンジ　As　Range)
　レンジ.Insert　Shift:=xlDown,　CopyOrigin:=xlFormatFromLeftOrAbove
End　Sub

お礼

すみません、テストファイルでは確かにできているのですが、実際のデータを入れてやってみると、最初の上の方は下がっているのですが、番号が合致しない行が白紙行とならずに詰まってタイトルが始まっています。

補足

B1の「見出し」も移動してほしいです。あと、赤の番号はA7から始まります。

回答No.1

Nouble

〉黒の番号がないときはその行を18まで空白行にする、
〉黒の(中略)番号がぬけている(中略)際には(中略)行(中略)を空白行に

無い、跳ぶ、抜ける、
は、
存在が、ない
と、いう意味で
同じ、事
故に、
処理上、同じ
です

どちらで、しょう？
どちらで、処理
するの、ですか？