Excelのレコードクリア (ID:115625)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

>Excelのセル内を削除する方法を教えていただきたいです。
>それには情報がたりませんか？
削除する方法はきのこさんのコードであってます。
>xlSheet.Cells(n, 1).Delete

>とやると、最後のレコードしか消えません。
これは最後の行だけは消える処理が成功しているという事ですよね？
削除する方法は多分あってるんだと思います。
じゃあ、原因はどこか？…デバッグしないと分かりません(＾＾；)。
情報が足りないと言えば足りないですが、どこにエラーがあるかは
限定できません。…ソースを全て載せられても…困りますし。

DAO を使わない(Worksheet オブジェクトと配列を使った)サンプル
を載せておきます。データを削除する処理は作ってありますが
使ってません。
[VB6.0]
Option Explicit
 
Private xlApp   As Excel.Application
Private xlBook As Excel.Workbook
Private xlSheet As Excel.Worksheet

Private Const xlFilePath As String = "c:\test.xls" ' 既存のファイルを利用する場合に設定
Private Const TopCellRow As Long = 6    ' データとして利用する先頭行
Private Const TopCellCol As Long = 1    ' データとして利用する先頭列
Private mTopCellAddress As String
Private mLastCell As Excel.Range        ' 使用されている最終セルを格納

' Excel ワークシートの仕様制限 65,536 行、256 列
Private Const RowMax As Long = 65536
Private Const ColMax As Long = 256

Private mData() As Variant

Private Sub Form_Load()
    ' 使用したコントロールは Command1 Command2 Command3 Command4 ListView1
    Me.Command1.Caption = "Read"
    Me.Command2.Caption = "Delete のみ"
    Me.Command3.Caption = "Write のみ"
    Me.Command4.Caption = "Delete Write"
    With Me.ListView1
        .View = lvwReport
        .MultiSelect = True
        .FullRowSelect = True
        .Gridlines = True
    End With
    
    Set xlApp = CreateObject("Excel.Application")
    ' 既存のファイルが見つからない場合は、新規 Book
    If Len(Dir(xlFilePath, vbNormal)) = 0 Then
        Set xlBook = xlApp.Workbooks.Add
    Else
        Set xlBook = xlApp.Workbooks.Add(xlFilePath)
    End If
    Set xlSheet = xlBook.Worksheets(1)
    xlApp.Visible = True
    
    mTopCellAddress = GetCellAddressString(TopCellRow, TopCellCol)
    Set mLastCell = xlSheet.Cells.SpecialCells(Excel.XlCellType.xlCellTypeLastCell)
End Sub

Private Sub Command1_Click()
'    Dim i As Long
'    Dim j As Long
    
    mData = ExcelRead(mTopCellAddress, mLastCell.Row - TopCellRow + 1, mLastCell.Column - TopCellCol + 1)
    ' データの確認用コード
'    Debug.Print LBound(mData, 1)
'    Debug.Print LBound(mData, 2)
'    For i = LBound(mData, 1) To UBound(mData, 1)
'        For j = LBound(mData, 2) To UBound(mData, 2)
'            Debug.Print "$" & IntToAlphabet(j + TopCellCol - 1) & "$" & CStr(i + TopCellRow - 1) & " : " & CStr(mData(i, j))
'        Next
'    Next

Call SetListViewData(Me.ListView1, mData)
    
End Sub

Private Sub Command2_Click()
    ' データを削除したい場合はコメントから戻して下さい。
'    Call ExcelClear(mTopCellAddress, mLastCell.Row - TopCellRow + 1, mLastCell.Column - TopCellCol + 1)
End Sub

Private Sub Command3_Click()
'    Dim i As Long
'    Dim j As Long
    Call GetListViewData(Me.ListView1, mData)
    ' データの確認用コード
'    For i = LBound(mData, 1) To UBound(mData, 1)
'        For j = LBound(mData, 2) To UBound(mData, 2)
'            Debug.Print "$" & IntToAlphabet(j + TopCellCol - 1) & "$" & CStr(i + TopCellRow - 1) & " : " & CStr(mData(i, j))
'        Next
'    Next
    Call ExcelWrite(mTopCellAddress, mData)
End Sub

Private Sub Command4_Click()
'    Call Command2_Click
'    Call Command3_Click
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Dim TempPath As String
    TempPath = xlFilePath
    If MsgBox(TempPath & " に保存しますか？", vbOKCancel) = vbOK Then
        xlApp.DisplayAlerts = False
        xlSheet.SaveAs TempPath
        xlApp.DisplayAlerts = True
    End If
    
    On Error Resume Next
    xlBook.Saved = True
    
    xlApp.Quit

' オブジェクトを解放します。
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
End Sub

Private Sub ExcelWrite(ByVal TopCellAddress As String, ByRef Datax() As Variant)
    xlSheet.Range(TopCellAddress).Resize(UBound(Datax, 1), UBound(Datax, 2)).Value = Datax
End Sub
Private Sub ExcelClear(ByVal TopCellAddress As String, ByVal Rows As Long, Cols As Long)
    xlSheet.Range(TopCellAddress).Resize(Rows, Cols).Clear
    ' Delete だとセルごと削除
'    xlSheet.Range(TopCellAddress).Resize(Rows, Cols).Delete
End Sub
Private Function ExcelRead(ByVal TopCellAddress As String, ByVal Rows As Long, Cols As Long) As Variant()
    ExcelRead = xlSheet.Range(TopCellAddress).Resize(Rows, Cols).Value
End Function

Private Function IntToAlphabet(ByVal NumberX As Long) As String
    Dim wNum As Long
    Dim wStr As String
    If NumberX <= 0 Then
        NumberX = 1
    End If

' 26以上の時は再帰
    wNum = (NumberX - 1) \ 26
    If wNum >= 1 Then
        wStr = IntToAlphabet(wNum)
    End If

wNum = (NumberX - 1) Mod 26
    IntToAlphabet = wStr & Chr(Asc("A") + wNum)
End Function

Private Function GetCellAddressString(ByVal Row As Long, ByVal Col As Long) As String
    If RowMax < Row Then
        MsgBox "行数に Excel ワークシートの制限を越えた値が代入されました。"
        Row = RowMax
    End If
    If ColMax < Col Then
        MsgBox "列数に Excel ワークシートの制限を越えた値が代入されました。"
        Col = ColMax
    End If
    GetCellAddressString = "$" & IntToAlphabet(Col) & "$" & CStr(Row)
End Function

Private Sub SetListViewData(ByVal ListViewX As ListView, ByRef Data() As Variant)
    Dim i As Long
    Dim j As Long
    Dim wItem As ListItem
    
    With ListViewX
        With .ColumnHeaders
            .Clear
            For j = LBound(mData, 2) To UBound(mData, 2)
                .Add , , IntToAlphabet(j + TopCellCol - 1)
            Next
        End With
        With .ListItems
            .Clear
            For i = LBound(mData, 1) To UBound(mData, 1)
                For j = LBound(mData, 2) To UBound(mData, 2)
                    If j = LBound(mData, 2) Then
                        Set wItem = .Add(, , CStr(mData(i, j)))
                    Else
                        wItem.SubItems(j - 1) = CStr(mData(i, j))
                    End If
                Next
            Next
        End With
    End With
End Sub

Private Sub GetListViewData(ByVal ListViewX As ListView, ByRef Data() As Variant)
    Dim wRowMax As Long
    Dim wColMax As Long
    Dim i As Long
    Dim j As Long
    With ListViewX
        wRowMax = .ListItems.Count
        wColMax = .ColumnHeaders.Count
        With .ListItems
            For i = LBound(Data, 1) To UBound(Data, 1)
                For j = LBound(Data, 2) To UBound(Data, 2)
                    If i <= wRowMax And j <= wColMax Then
                        If j = LBound(Data, 2) Then
                            Data(i, j) = .Item(i)
                        Else
                            Data(i, j) = .Item(i).SubItems(j - 1)
                        End If
                    Else
                        Data(i, j) = ""
                    End If
                Next
            Next
        End With
    End With
End Sub

←解決時は質問者本人がここをチェックしてください。

戻る