Excel VBA質問箱 IV

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

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


15702 / 76738 ←次へ | 前へ→

【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

0 hits

【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 お礼

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