For p = 2 To e For n = 4 To w If Cells(p, n) = 1 Then Cells(p, n).ClearContents ' 清空单元格内容 End If Next Next修改清空單元格内百分之百的數據

你可以尝试以下代码：

For p = 2 To e
    For n = 4 To w
        If Cells(p, n) = 1 Then
            Cells(p, n).ClearContents ' 清空单元格内容
        End If
    Next n
Next p

这段代码会遍历从第二行到第e行，从第四列到第w列的所有单元格。如果单元格中的数值等于1，则会清空该单元格的内容。注意，清空的是百分之百的数据，也就是所有内容。如果你只想清空数值为100%的单元格，可以将条件改为`If Cells(p, n) = 1 And Cells(p, n).NumberFormat = "0%" Then`。

相关问题

w = Range("a1").CurrentRegion.Columns.Count - 1 e = Range("a1").CurrentRegion.Rows.Count For p = 2 To e For n = 3 To w If Cells(p, n) = 0 Then Cells(p, n).Delete End If Next Next將這段代碼修改為如果等於0，就清空

你可以像这样修改代码：

w = Range("a1").CurrentRegion.Columns.Count - 1
e = Range("a1").CurrentRegion.Rows.Count

For p = 2 To e
    For n = 3 To w
        If Cells(p, n) = 0 Then
            Cells(p, n).ClearContents ' 清空单元格内容
        End If
    Next
Next

这样，如果单元格的值等于0，就会清空它的内容。注意，使用`ClearContents` 方法只会清空单元格的内容，而不会删除单元格。如果你需要删除单元格，则需要使用`Delete` 方法。

帮我合并以下宏程序 Private Sub Worksheet_Change(ByVal Target As Range) Dim rng As Range, cell As Range Dim arr() As Variant Dim cnt As Long Dim isCopying As Boolean ' 如果B1单元格为空，直接退出Sub过程 If Me.Range("B1").Value = "" Then Exit Sub If Not Intersect(Target, Me.Range("B1")) Is Nothing Then Sheets("点位提取").Range("C5:C200").ClearContents If Me.Range("AH34").Value = True Then Me.ListBox1.AddItem "数据已被清空 " & Format(Now, "hh:mm:ss") Me.ListBox1.ListIndex = Me.ListBox1.ListCount - 1 End If Set rng = Me.Range("B1:B2000") cnt = 0 isCopying = False For Each cell In rng If cell.Value = ":BEGIN" Then isCopying = True ReDim arr(2000) If Me.Range("AH34").Value = True Then Me.ListBox1.AddItem "开始提取数据 " & Format(Now, "hh:mm:ss") Me.ListBox1.ListIndex = Me.ListBox1.ListCount - 1 End If ElseIf cell.Value = ":END" Then isCopying = False ReDim Preserve arr(cnt - 1) Sheets("点位提取").Range("C5").Resize(cnt, 1).Value = Application.Transpose(arr) If Me.Range("AH34").Value = True Then Me.ListBox1.AddItem "数据已进行提取完毕 " & Format(Now, "hh:mm:ss") Me.ListBox1.ListIndex = Me.ListBox1.ListCount - 1 End If Exit For End If If isCopying And cell.Value <> ":BEGIN" Then arr(cnt) = rng.Cells(cell.Row, 1).Value cnt = cnt + 1 End If Next cell End If On Error GoTo ErrorHandler Exit Sub ErrorHandler: If Me.Range("AH36").Value = True Then Me.ListBox2.AddItem Err.Description & " " & Format(Now, "hh:mm:ss") Me.ListBox2.ListIndex = Me.ListBox2.ListCount - 1 End If End Sub Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Integer Dim j As Integer Dim k As Integer Dim ws As Worksheet Set ws = ActiveSheet If Target.Address = "$B$2" Then For i = 9 To 40 For j = 2 To 7 If ws.Cells(i, j).Value = ws.Cells(8, 5).Value Then For k = 3 To 4 ws.Cells(i, j + k - 2).Value = ws.Cells(Application.Match(ws.Cells(i, 1).Value, ws.Range("AK9:AK40"), 0) + 8, k).Value Next k End If Next j Next i End If End Sub

可以将两个Sub过程合并为一个，代码如下：

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range, cell As Range
    Dim arr() As Variant
    Dim cnt As Long
    Dim isCopying As Boolean
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim ws As Worksheet
    
    Set ws = ActiveSheet
    
    ' 如果B1单元格为空，直接退出Sub过程
    If Me.Range("B1").Value = "" Then Exit Sub
    
    If Not Intersect(Target, Me.Range("B1")) Is Nothing Then
        Sheets("点位提取").Range("C5:C200").ClearContents
        
        If Me.Range("AH34").Value = True Then
            Me.ListBox1.AddItem "数据已被清空 " & Format(Now, "hh:mm:ss")
            Me.ListBox1.ListIndex = Me.ListBox1.ListCount - 1
        End If
        
        Set rng = Me.Range("B1:B2000")
        cnt = 0
        isCopying = False
        
        For Each cell In rng
            If cell.Value = ":BEGIN" Then
                isCopying = True
                ReDim arr(2000)
                
                If Me.Range("AH34").Value = True Then
                    Me.ListBox1.AddItem "开始提取数据 " & Format(Now, "hh:mm:ss")
                    Me.ListBox1.ListIndex = Me.ListBox1.ListCount - 1
                End If
                
            ElseIf cell.Value = ":END" Then
                isCopying = False
                ReDim Preserve arr(cnt - 1)
                Sheets("点位提取").Range("C5").Resize(cnt, 1).Value = Application.Transpose(arr)
                
                If Me.Range("AH34").Value = True Then
                    Me.ListBox1.AddItem "数据已进行提取完毕 " & Format(Now, "hh:mm:ss")
                    Me.ListBox1.ListIndex = Me.ListBox1.ListCount - 1
                End If
                
                Exit For
                
            End If
            
            If isCopying And cell.Value <> ":BEGIN" Then
                arr(cnt) = rng.Cells(cell.Row, 1).Value
                cnt = cnt + 1
            End If
            
        Next cell
        
        If Target.Address = "$B$2" Then
            For i = 9 To 40
                For j = 2 To 7
                    If ws.Cells(i, j).Value = ws.Cells(8, 5).Value Then
                        For k = 3 To 4
                            ws.Cells(i, j + k - 2).Value = ws.Cells(Application.Match(ws.Cells(i, 1).Value, ws.Range("AK9:AK40"), 0) + 8, k).Value
                        Next k
                    End If
                Next j
            Next i
        End If
        
    End If
    
    On Error GoTo ErrorHandler
    
    Exit Sub
    
ErrorHandler:
    
    If Me.Range("AH36").Value = True Then
        Me.ListBox2.AddItem Err.Description & " " & Format(Now, "hh:mm:ss")
        Me.ListBox2.ListIndex = Me.ListBox2.ListCount - 1
    End If
    
End Sub