質問番号：1418054103
ExcelのA-AY列において、同一コードを持つ行を結合させたいです。ただ、P列からT列は除外し、同一コードの行の結合がAY列まで終了次第、直下に1行追加→P-T列は追加された行の各セルに、数値の合計を計算。→その動作を1500行ぐらい繰り返したいのですが。
そんなマクロって、可能でしょうか？
今、D列に、図のようなデータが並んでおります。（1）まず、100、200、300、400…とありますが、それぞれ同じデータがセルにあれば1つに結合します。
（2）そしてそれを水平展開し、他の列もD列と同じように結合していきます。（P-T列を除く）
1つのコードに対応する結合データが、AYまでの全ての列で展開できましたら。
（3）1行挿入し、P-T列のデータをこの http://f.st-hatena.com/images/fotolife/m/moon-fondu/20141209/20141209005013.jpg?1418053841 ように、隣接する結合セルの範囲毎に集計。（1）に戻り、1500行の所まで繰り返す…といった処理をマクロで行いたいのですが。
もし、複雑になりすぎるようでしたら、結合→1行挿入の繰り返しだけでも構いません。
サンプルファイルはこちら http://xfs.jp/LMPmT に置きました。
お力添えをいただければ幸いです。よろしくお願い致します。
質問内容（セルの結合部分）がイマイチ不明な為、一部の列のみを結合したソースコードを書いてみた。
（他の列を結合させたい場合は、結合させたい列分だけコードを追加すればOK）
Option Explicit
Sub main()
Dim lp As Long ' カウンタ
Dim LastRow As Integer ' 最終行
Dim RowCount As Long ' 結合・合計するセル行数
' セルマージ時に出るメッセージをブロック
Application.DisplayAlerts = False
' サンプルシートをコピー
If Worksheets.count = 1 Then
Worksheets(1).Copy After:=Sheets(1)
End If
RowCount = 1 ' 結合・合計行カウントセット
' コピーしたシートで処理
With Worksheets(2)
LastRow = .Cells(Rows.count, 1).End(xlUp).Row + 1 ' 最終行
lp = 2 ' 1行目は見出し
' 最終行まで処理
Do
' D列セルと直後のD列セルを比較。 違っていたら合計用の行挿入及び合計をセルにセット
If .Range("D" & lp) <> .Range("D" & lp + 1) Then
' 合計行挿入
.Range(lp + 1 & ":" & lp + 1).Insert
' P列にセル行数、Q〜T列に合計をセット
.Range("P" & lp + 1) = RowCount
.Range("Q" & lp + 1) = WorksheetFunction.Sum(.Range("Q" & lp - RowCount + 1 & ":" & "Q" & lp))
.Range("R" & lp + 1) = WorksheetFunction.Sum(.Range("R" & lp - RowCount + 1 & ":" & "R" & lp))
.Range("S" & lp + 1) = WorksheetFunction.Sum(.Range("S" & lp - RowCount + 1 & ":" & "S" & lp))
.Range("T" & lp + 1) = WorksheetFunction.Sum(.Range("T" & lp - RowCount + 1 & ":" & "T" & lp))
.Range("P" & lp + 1 & ":" & "T" & lp + 1).Font.Color = vbRed
' セルの結合（とりあえずB列とD列のみ C列とE列のセルにcountif関数が入っている為、セル結合後計算結果が変わる）
.Range("B" & lp - RowCount + 1 & ":" & "B" & lp).Merge
.Range("D" & lp - RowCount + 1 & ":" & "D" & lp).Merge
LastRow = LastRow + 1 ' 合計行（1行）を追加
lp = lp + 2 ' 合計行＋次行移動
RowCount = 1 ' 結合・合計行カウントセット
Else
RowCount = RowCount + 1 ' 結合・合計行カウントアップ
lp = lp + 1 ' 次行移動
End If
Loop While lp + 1 <= LastRow
End With
End Sub
質問番号：1416819276
Excelにて指定した範囲のデータをコピーし、起点のセルから3行置きに挿入していきたいです。
今、添付の画像のようなデータがあります。
5行目から20行目のデータを、関数も含めてコピーしまして。
それを、23行目の真下、26行目、29行目、32行目、35行目の真下・・・と、23行目を起点に、3行置きにコピーしたデータを挿入していきたいのです。
そしてその処理を5万行ほど行いたいのですが。
何かこれを実現するマクロ等、ご存知でしたらお教えいただけないでしょうか。
サンプルファイルもこちら http://xfs.jp/S92fHS に置きました。
お手数ですがどなたかよろしくお願い致します。
Option Explicit
Sub main()
Dim LastRow As Long
Dim LoopCount As Long
Dim InsertRow As Long
Dim lp As Long
If Worksheets.Count = 1 Then
Worksheets("Sheet1").Copy After:=Worksheets("Sheet1")
Worksheets(2).Name = "Sheet2"
End If
With Worksheets(2)
LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
LoopCount = Application.RoundUp((LastRow - 20) / 3, 0)
InsertRow = 24
For lp = 1 To LoopCount
.Range("5:20").Copy
.Range(InsertRow & ":" & InsertRow + 16).Insert
InsertRow = InsertRow + 19
Next lp
End With
End Sub
質問番号：1416654240
Option Explicit
Sub main()
Dim LastRow As Long
Dim CopyRow As Long
Dim lp As Long
Worksheets(2).Cells.Clear
LastRow = Me.Range("E" & Rows.Count).End(xlUp).Row
CopyRow = 1
For lp = 3 To LastRow
If InStr(Range("E" & lp), "あいうえお") > 0 Then
Me.Range(lp - 2 & ":" & lp).Copy
Worksheets(2).Range(CopyRow & ":" & CopyRow + 2).PasteSpecial
CopyRow = CopyRow + 3
End If
Next lp
End Sub
2012-11-02 のつぶやき
- 20:18 そういえば、来年度の県職員採用試験（非常勤）の申込みをしてなかった。 今はネットでできるみたいだからこの週末申込みをしておこう。
- 20:15 isogayaさんは自分で物事を探す力を身に付けるべきだと思う。何でもアウトソースで解決しようとする人に思考法は必要？ RT @ken3memo: 思考法の本。私も知りたい。 / “思考法についての本を探しています- 人力検索はてな” http://t.co/Ufy0SeSE
- 20:10 今年も実家の年賀状はこのソフトで作る予定。（私はウェブポで^^;） / “はがきデザインキット｜日本郵便” http://t.co/rjt5ie3R
Powered by twtr2src
2012-10-28 のつぶやき
- 23:55 あ〜あ、今までず〜と思っていたけど、云えなかった人力検索廃止論をハイクに投稿しちゃった。 （と云ってもヘタレなので自身のIDページで） こんな過激な事を投稿しても読む人は殆どいないからいいか^^; http://t.co/W8aabNfT
Powered by twtr2src
