![](/img/trans.png)
[英]How to check for a value across columns and then copy the the contents of one cell below it?
[英]VBA - How to Clear Cell Contents across Multiple Columns if Value not Contained
我有一個宏,它在從 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
似乎您正在繼續使用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
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.