宏更改以修复特定的列不会被删除

Question

我有一个宏，它没有删除我需要的特定列中的正确单元格。

Sub do_it()

Dim sht As Worksheet,  n As String,    cell,  num,  tmp,  rngDest As Range,  i As Integer
Set sht  = ActiveSheet
n = sht.Range("A1").Value i = 0
For Each cell In   sht.Range("A20:A34,D20:D34,H20:H34").Cells
tmp = cell.Offset(0, 1).Value
If cell.Value = n And tmp Like "*#-#*"    Then 'get the first number
num = CLng(Trim(Split(tmp, "-")(0)))  'find the next empty cell in the appropriate    row
Set rngDest = sht.Cells(num,   sht.Columns.Count).End(xlToLeft).Offset(0, 1)

'make sure not to add before col J
If rngDest.Column < 12 Then Set rngDest  = sht.Cells(num, 12)
cell.Offset(0, 1).Copy rngDest

' This is getting the next number in A/D/H----
Set tmp = cell.Offset(1, 0)

' This is filling up B17 - F18 in order until filled
If sht.Range("B17").Value = "" Then
sht.Range("C17").Value = cell.Offset(0, 1).Value
sht.Range("B17").Value = tmp.Value
ElseIf sht.Range("C18").Value = "" Then
sht.Range("C18").Value = cell.Offset(0, 1).Value
sht.Range("B18").Value = tmp.Value
ElseIf sht.Range("E17").Value = "" Then
sht.Range("E17").Value = cell.Offset(0, 1).Value
sht.Range("D17").Value = tmp.Value
ElseIf sht.Range("E18").Value = "" Then
sht.Range("E18").Value = cell.Offset(0, 1).Value
sht.Range("D18").Value = tmp.Value
End If '---- This clears the B columns  after using the value ----

Dim rg As Range, rg1 As Range
If cell.Column = 1 Then 
    Set rg = cell.Offset(, 1).Resize(, 1)
If cell.Column > 1 Then Set rg1 = cell.Offset(, 1).Resize(, 2)
End If

Next cell
If Not rg Is Nothing Then  rg.ClearContents 'will be delete column b

'如果不是rg1不存在，则rg1.ClearContents'将被删除列e，f，g，     结束

使用上传的Excel图像，我需要进行的操作如下：

宏可以完成很多事情，并且可以正常工作。唯一的问题是在复制和粘贴过程之后删除正确的列。 一旦在单元格A1中输入了找到的数字（在这种情况下为8），并且在单元格范围A20：A34（单元格B34）中找到了，那么会发生很多事情，这些事情可以正常进行。仅在此单元格范围内，我需要在复制和发布后删除单元格B34的内容。 当在单元格区域D20：D34和H20：H34中找到找到的数字时，会发生许多正常工作的事情。复制和粘贴功能完成后，我需要删除单元格E20 / F20 / G20和I / J / K。

Excel工作表：

Answer 1

欢迎光临！

为了实现这一目标：

在单元格A1中输入的数字（在这种情况下为8） 范围A20：A34（单元格B34），仅在此单元格范围内，我需要 复制并粘贴后要删除的单元格B34的内容。

当在单元格区域D20：D34和H20：H34中找到数字时，我需要 复制和粘贴后要删除的单元格E20 / F20 / G20和I / J / K 功能已完成。

您需要替换代码的这一部分：

        Dim rg As Range, rg1 As Range
        If cell.Column = 1 Then
            Set rg = cell.Offset(, 1).Resize(, 1)
            If cell.Column > 1 Then Set rg1 = cell.Offset(, 1).Resize(, 2)
        End If

与此：

        Select Case cell.Column
        Case 1 'If found in column A, delete the next cell
            cell.Offset(, 1).ClearContents
        Case 4, 8 'If found in column D or H, delete cells E20/F20/G20 AND I/J/K
            Range("D20:D34,H20:H34,I:I,J:J,K:K").ClearContents
        End Select