如果不包含值，如何跨多个列清除单元格内容

Question

我有一个宏，在从列D开始的一系列列中创建数据，其中n=iCount。
。如果iCount=4，则列为D, E, F, g

在所有这些列中，如果单元格不包含"[AT]"，我希望清除单元格内容。

最理想的情况是，我还希望将所有剩余的数据移到左边，这意味着每一行的数据从D列开始，没有空白，但这是次要的。

我的宏的前面部分。

Dim Treffer As Worksheet
Dim iCount As Long
Dim i As Long
Set Treffer = ActiveWorkbook.Worksheets("Treffer")
iCount = InputBox(Prompt:="How many columns should be created?")
For i = 1 To iCount
Treffer.Columns(5).EntireColumn.Insert
Treffer.Range("E1").Value = "Anmelder" & (iCount + 1) - i
Next i

Treffer.Range("D2:D" & Treffer.Cells(Rows.Count, "D").End(xlUp).Row).TextToColumns , _
Destination:=Treffer.Range("E2:E" & Treffer.Cells(Rows.Count, "N").End(xlUp).Row), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="" & Chr(10) & "", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
Treffer.Columns(4).EntireColumn.Delete

Answer 1

似乎你正在创造更多的工作继续使用TextToColumns，并将更好地使用Split()。
尝试这样做:

Sub Tester()
Dim Treffer As Worksheet
Dim iCount As Long, i As Long, arr, c As Range, os As Long, v

Set Treffer = ActiveWorkbook.Worksheets("Treffer")

iCount = InputBox(Prompt:="How many columns should be created?")
For i = 1 To iCount
Treffer.Columns(5).EntireColumn.Insert
Treffer.Range("E1").Value = "Anmelder" & (iCount + 1) - i
Next i

For Each c In Treffer.Range("D2:D" & Treffer.Cells(Rows.Count, "D").End(xlUp).Row).Cells
If Len(c.Value) > 0 Then                   'cell has a value?
arr = Split(c.Value, vbLf)             'split value on Chr(10)
os = 1                                 'reset column offset
For Each v In arr                      'loop over array values
If InStr(1, v, "[AT]") > 0 Then    'value contains "[AT]" ?
c.Offset(0, os).Value = v      'populate in offset column
os = os + 1                    'next column to right
If os > iCount Then Exit For   'stop if reached column count limit
End If 'value has [AT]
Next v
End If         'any cell value
Next c

Treffer.Columns(4).EntireColumn.Delete
End Sub