Excel エクセルの行削除を使わずVBAで行削除しデータを詰める例

コード

Option Explicit

Sub prog1()

     Const COMPANY_START_ROW As Long = 2
     Const COMPANY_LAST_ROW As Long = 10

     Dim ws As Worksheet
     Set ws = ThisWorkbook.Sheets("Sheet1")

     ws.Cells.Clear
     
     Dim companyNameLastRow As Long
     companyNameLastRow = 10

     ws.Cells(1, "A").Value = "会社名(削除前)"
     Dim companyNameNowRow As Long
     For companyNameNowRow = COMPANY_START_ROW To COMPANY_LAST_ROW

        ws.Cells(companyNameNowRow, "A").Value = Chr(63 + companyNameNowRow) & "社" 'A～

     Next companyNameNowRow
     
     Dim userInput As String
     userInput = InputBox("どの行を削除したいですか? 行番号を指定して下さい(複数選択する場合は間に空白を入れて下さい 例: 3 5 9、7 2 5など)")
     
     Dim parts() As String
     parts = Split(userInput, " ") ' Split by space
  
     Dim i As Long
     For i = LBound(parts) To UBound(parts)
      
         If IsNumeric(parts(i)) = True Then
         
             If COMPANY_START_ROW <= CLng(parts(i)) And CLng(parts(i)) <= COMPANY_LAST_ROW Then
         
                Debug.Print "Part " & i & ": " & parts(i)
                
             Else
             
                MsgBox (COMPANY_START_ROW & "から" & COMPANY_LAST_ROW & "の数値ではありません。終了します。")
                
                Exit Sub
                
             End If
           
         Else
         
             MsgBox ("数値ではありません。終了します。")
           
             Exit Sub
           
         End If
         
     Next i
     
     Range("A1:A" & COMPANY_LAST_ROW).Copy Destination:=ws.Range("B1")
     ws.Cells(1, "B").Value = "会社名(削除後)"
     
     ' process of coloring company to be removed
     For companyNameNowRow = COMPANY_START_ROW To COMPANY_LAST_ROW
        
        For i = LBound(parts) To UBound(parts)
        
           If CLng(parts(i)) = companyNameNowRow Then
              
              ws.Cells(companyNameNowRow, "A").Interior.ColorIndex = 3
               
           End If
           
        Next i

     Next companyNameNowRow
     
     ' process of clearing company List
     For i = LBound(parts) To UBound(parts)
     
         ws.Range("B" & CLng(parts(i))).ClearContents
        
     Next i
     
     ' process of shifting up
     For companyNameNowRow = COMPANY_START_ROW To COMPANY_LAST_ROW
     
         If ws.Cells(companyNameNowRow, "B") <> "" Then
         
            While ws.Cells(companyNameNowRow - 1, "B") = "" And COMPANY_START_ROW <= companyNameNowRow - 1
              
              ws.Cells(companyNameNowRow - 1, "B") = ws.Cells(companyNameNowRow, "B")
              ws.Cells(companyNameNowRow, "B").ClearContents
              
              companyNameNowRow = companyNameNowRow - 1
               
            Wend
            
         End If
     
     Next companyNameNowRow
     
     ws.Activate
     
     Set ws = Nothing

End Sub

実行結果(1)

実行結果(2)

手順(実行結果(2))

一部抜粋

     'process of shifting up
     For companyNameNowRow = COMPANY_START_ROW:2 To COMPANY_LAST_ROW:10
     
         If ws.Cells(companyNameNowRow, "B") <> "" Then
         
            While ws.Cells(companyNameNowRow - 1, "B") = "" And COMPANY_START_ROW <= companyNameNowRow - 1
              
              ws.Cells(companyNameNowRow - 1, "B") = ws.Cells(companyNameNowRow, "B")
              ws.Cells(companyNameNowRow, "B").ClearContents
              
              companyNameNowRow = companyNameNowRow - 1
               
            Wend
            
         End If
     
     Next companyNameNowRow