エクセルVBAでOFFSET指定で行増減する時追従

質問

エクセルVBA2013で質問です。
C3:I3セルが結合してあり日付が入っています。
同じくJ3:P3も結合してあり日付が入っています。
同じように1週間分隣も続いています。
下側は作業者毎の表になっています。
C3:I3を月曜とすると、その下のC4:I17に作業者Aの月曜日分の内容、
C19:I32が作業者Bの火曜日分の内容となっています。

これを、日付セルを選択して、VBAを実行して各作業者の内容をコピーしてよそに貼り付けるのですが、
例えば、月曜の作業者Aの内容コピーなら、

ActiveCell.Offset(1, 0).Resize(14, 7).COPY

でコピーできまていますが、各作業者の内容を増やすことがあります。
作業者Aの内容は4行目から17行目までを最初ありますが、これを増やしたり場合によっては減らしたりして17が20行目までとなったりします。
例えば、20行目まで増やしたとすると、作業者Aの月曜日分は、C4:I20までになります。以下、作業者Bの位置もずれます。
名前を定義して指定すれば、増やしても減らしても追従するのかな？と思いましたがどうすればよいかよく分かりません。
名前の定義も各作業者の各曜日で定義する必要があるのか、それとも作業者の項目で定義して、

ActiveCell.Offset("作業者A",0).Resize("作業者A", 7).COPY

のような行のみ名前で指定でできないのかな？とも思いました。
上のは動きませんでしたが・・・。

行を増やしたり減らしたりしてもうまく追従してくれるやり方が何かいい方法がありますか？

回答No.1

keithin · ベストアンサー

準備：
４行から１７行までの「行範囲」にまとめて「作業者Ａ」と名前を定義する。

手順：
application.intersect(activecell.mergearea.entirecolumn, range("作業者Ａ")).copy
のようにして範囲を指定する。

＞行を増やしたり減らしたりしてもうまく追従してくれるやり方が何かいい方法

行を増やした減らしたと「言葉で言ってる」だけじゃなく、具体的にいま対象の範囲がどこからどこまでなのか、あなたのエクセルで「いま調べる方法」を考えて次からもっと工夫してください。

たとえばＡ列がこれこれになってる範囲が作業者一人分の範囲だとか。
たとえば３行目が日付でセル結合されているとして、次に同じようにセル結合されてる１８行目や１９行目までの範囲がヒトカタマリになるとか。

お礼

思い通りになりました。
どうもありがとうございました。

回答No.4

kkkkkm

No2のまた訂正と補足です。

訂正
もし質問のように作業者Aと作業者Bの行数が同じになるのでしたらbは求めなくてよくて
↓
もし質問のように作業者Aと作業者Bの行数が同じになるのでしたらbは一度だけ求めればよくて

あと補足として
もとがCopyを使っていたので
ActiveCell.Offset(1, 0).Resize(BottomRow - FastRow, 7).Copy
Sheets("Sheet2").Cells(FastRow, "C").PasteSpecial

にしましたが、以下のほうが比較にならないくらい早いです。
Sheets("Sheet2").Cells(FastRow, "C").Resize(BottomRow - FastRow + 1, 7).Value = ActiveCell.Offset(1, 0).Resize(BottomRow - FastRow + 1, 7).Value

なお、ActiveCellを利用しているので実行時に本来のセルを選択してるかどうかのチェックは一番最初にしておかないととんでもないことになります。

お礼

どうもありがとうございました。
アクティブセルの位置チェックは最初に行うようにしています。
参考になりました。

回答No.3

kkkkkm

No2です。訂正です。

ActiveCell.Offset(1, 0).Resize(BottomRow - FastRow, 7).Copy
↓
ActiveCell.Offset(1, 0).Resize(BottomRow - FastRow + 1, 7).Copy

お礼

どうもありがとうございました。

回答No.2

kkkkkm

> C3:I3を月曜とすると、その下のC4:I17に作業者Aの月曜日分の内容、
> C19:I32が作業者Bの火曜日分の内容となっています。

上は作業者Aの月曜日分で下は作業者Bの火曜日分ですか?この辺がよくわかりませんが、とりあえず作業者Aと作業者Bの間にだけ空白(何もデータが入ってない)の行があるとして考えてみました。で、空白の行を探すということで、ActiveCellを移動しながら

ActiveCell.Offset(1, 0).Resize(b, 7).COPY

で、bを求めればいいわけですよね。もし質問のように作業者Aと作業者Bの行数が同じになるのでしたらbは求めなくてよくてActiveCellを移動だけすればいいことになります。

とりあえず、空白の行を探しActiveCellを移動しbを求めるということで速度は遅いですが、参考までに

Sub Example()
Dim i As Long, TopRow As Long, BottomRow As Long, FastRow As Long, LastRow As Long
Dim m_Column As Long

Application.ScreenUpdating = False
FastRow = ActiveCell.Offset(1, 0).Row
LastRow = ActiveCell.SpecialCells(xlLastCell).Row
m_Column = ActiveCell.Column

For i = 1 To 2
Call CopyPaste(FastRow, LastRow, m_Column)
Next i
Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub

Private Sub CopyPaste(ByRef FastRow As Long, ByRef LastRow As Long, ByVal m_Column As Long)
Dim i As Long, BottomRow As Long

BottomRow = LastRow
For i = FastRow To LastRow
If Cells(i, m_Column) = "" Then
BottomRow = i
Exit For
End If
Next i
ActiveCell.Offset(1, 0).Resize(BottomRow - FastRow, 7).Copy

Sheets("Sheet2").Cells(FastRow, "C").PasteSpecial
'貼り付け先は不明なのでとりあえすSheet2にしています。

Cells(BottomRow, m_Column).Activate
FastRow = BottomRow + 1

End Sub

お礼

どうもありがとうございました。

補足

> C3:I3を月曜とすると、その下のC4:I17に作業者Aの月曜日分の内容、
> C19:I32が作業者Bの火曜日分の内容となっています。
火曜→月曜の間違いでした。火曜日分はJ:P列でした。

試してみました。空白行を探すのですが、このやり方だと内容を隙間を開けて入力していると必要な所まで取得できませんでした。

NO1さんのやり方を試したところうまくできました。
でも参考になりました。どうもありがとうございました。