Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


2700 / 13646 ツリー ←次へ | 前へ→

【66507】空白行挿入→セル移動→結合 ひらた 10/9/7(火) 17:37 質問[未読]
【66508】Re:空白行挿入→セル移動→結合 UO3 10/9/7(火) 18:55 回答[未読]
【66509】Re:空白行挿入→セル移動→結合 UO3 10/9/7(火) 19:18 回答[未読]
【66510】Re:空白行挿入→セル移動→結合 ひらた 10/9/7(火) 19:35 お礼[未読]
【66511】Re:空白行挿入→セル移動→結合 Hirofumi 10/9/7(火) 20:06 回答[未読]
【66520】Re:空白行挿入→セル移動→結合 ひらた 10/9/8(水) 10:46 お礼[未読]

【66507】空白行挿入→セル移動→結合
質問  ひらた  - 10/9/7(火) 17:37 -

引用なし
パスワード
   全く分からないのですが…データが大量なので、
マクロで自動的に処理する方法はありますでしょうか?
ご教授頂ければ幸いです。

A1 B1 C1
A2 B2 C2
A3 B3 C3
… … …
AX BX CX

とあるデータの各行にまず空白行を挿入し、
C列をB直下の行に移動して、さらにA1は下の空白セルと結合させたいのです。


A1 B1
  C1
A2 B2
  C2
A3 B3
  C3
… …
  …
AX BX
  CX

↑といった感じです。

データの終わりはいま例では「X」としましたが、
100〜200程度で、数はバラバラです。

うまく表現できていませんが、宜しくお願い致します。

【66508】Re:空白行挿入→セル移動→結合
回答  UO3  - 10/9/7(火) 18:55 -

引用なし
パスワード
   ▼ひらた さん:

こんばんは

いろんな方法がありますが、行数が膨大でなければ以下のようなコードでも。

Sub Sample()
Dim v() As String
Dim i As Long, z As Long
 Application.ScreenUpdating = False
 With Worksheets("Sheet1")  '<== 実際のシート名に
  z = .Range("A" & .Rows.Count).End(xlUp).Row
  ReDim v(2 To z)
  For i = 2 To z
   v(i) = i & ":" & i
  Next
  .Range(Join(v, ",")).Insert shift:=xlDown
  z = .Range("A" & .Rows.Count).End(xlUp).Row
  For i = 1 To z Step 2
   .Range("B" & i + 1).Value = .Range("C" & i).Value
   .Range("C" & i).ClearContents
   .Range("A" & i).Resize(2).MergeCells = True
  Next
 End With
 Application.ScreenUpdating = True
End Sub

【66509】Re:空白行挿入→セル移動→結合
回答  UO3  - 10/9/7(火) 19:18 -

引用なし
パスワード
   ▼ひらた さん:

ごめんなさい。
↑は、一挙に行挿入をしていますが、行数が多くなればエラーになりますね。
とりあえず以下に変更します。
ただ、1万行でテストしましたら私の環境で15秒もかかっていますので
あまり、いいコードではないですが。

Sub Sample2()
Dim v() As String
Dim i As Long, z As Long
Dim c As Range
 Application.ScreenUpdating = False
 With Worksheets("Sheet1")  '<== 実際のシート名に
  z = .Range("A" & .Rows.Count).End(xlUp).Row
  ReDim v(1 To z * 2, 1 To 3)
  i = 1
  For Each c In .Range("A1").CurrentRegion.Resize(, 1)
   v(i, 1) = c.Value
   v(i, 2) = c.Offset(, 1).Value
   v(i + 1, 2) = c.Offset(, 2).Value
   i = i + 2
  Next
  .Range("A1").Resize(z * 2, 3) = v
  z = .Range("A" & .Rows.Count).End(xlUp).Row
  For i = 1 To z Step 2
   .Range("A" & i).Resize(2).MergeCells = True
  Next
 End With
 Application.ScreenUpdating = True
End Sub

【66510】Re:空白行挿入→セル移動→結合
お礼  ひらた  - 10/9/7(火) 19:35 -

引用なし
パスワード
   UO3さま

こんなに早くご回答いただけるとは思っていませんでした、
ありがとうございました!
最初エラーになってしまったので、いじれる範囲でやってみたのですが、
結局動かず、どうしようかと思っていたら2つめのコードが!

本当に助かりました!
ありがとうございます。

【66511】Re:空白行挿入→セル移動→結合
回答  Hirofumi  - 10/9/7(火) 20:06 -

引用なし
パスワード
   もう見ていないかな?
手動で操作する手順ほぼそのままで

Option Explicit

Public Sub Sample_1()

  'Listのデータ列数(A列〜C列)
  Const clngColumns As Long = 3
  '分割位置と成る列位置(基準列からの列Offset:2列目=C列)
  Const clngSplit As Long = 2
  
  Dim i As Long
  Dim lngRows As Long
  Dim rngList As Range
  Dim lngKeys() As Long
  
  Dim strProm As String

  'Listの先頭セル位置を基準とする(先頭列の列見出しのセル位置)
  Set rngList = ActiveSheet.Range("A1")

  '画面更新を停止
  Application.ScreenUpdating = False
  
  With rngList
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row + 1
    If lngRows <= 1 And .Value = "" Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    '整列Keyを作成
    ReDim lngKeys(1 To lngRows, 1 To 1)
    For i = 1 To lngRows
      lngKeys(i, 1) = i
    Next i
    'Listの分割列以降をB列最終行の下にCut&Paste
    .Offset(, clngSplit).Resize(lngRows, clngColumns - clngSplit).Cut _
        Destination:=.Offset(lngRows, clngSplit - 1)
    '現在の最終列の後ろ(C列)に連番を付加
    .Offset(, clngSplit).Resize(lngRows).Value = lngKeys
    .Offset(lngRows, clngSplit).Resize(lngRows).Value = lngKeys
    '連番をKeyにListを整列
    .Resize(lngRows * 2, clngColumns - clngSplit + 2).Sort _
        Key1:=.Offset(, clngSplit), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    '連番を消去
    .Offset(, clngSplit).EntireColumn.ClearContents
    'A列をMerge
    For i = 1 To lngRows * 2 Step 2
      .Cells(i, 1).Resize(2).Merge
    Next i
  End With
  
  strProm = "処理が完了しました"
   
Wayout:

  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList = Nothing
   
  MsgBox strProm, vbInformation
     
End Sub

【66520】Re:空白行挿入→セル移動→結合
お礼  ひらた  - 10/9/8(水) 10:46 -

引用なし
パスワード
   Hirofumiさま

お返事遅れてすみません。
ご丁寧にありがとうございました。

UO3さまのと合わせて試してみたいと思います。

またこれを機にVBAの勉強をしてみようかとも思いました。

ご親切に感謝します!

2700 / 13646 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free