Question

我对vb很新，请尽可能帮助我。我有一系列数据，从N5到R24，所有单元格都包含公式，但只有少数是非空白单元格。

我想只将那些非空白单元格复制到列AK，并添加字符串＆＃34; / CA＆＃34;对于他们。如果N列中的单元格是“批量”，请在添加＆＃34; / CA＆＃34;之前先在B列中添加数字，如下所示：

         B          N     O      P     Q     R     S           T
5                 1PLA  2PMC                                 1PLA/CA
6  123-01456789   1BULK                                      2PMC/CA
7                 1AKE                                1BULK/123-01456789/CA
8                                                             1AKE
9
10

AK列中的顺序并不重要，只要它包含范围内的所有非空白单元格数据（N5：R24）。

以下代码是我尝试过的，但我不知道在粘贴后如何在B列中添加字符串或数据：

Sub test()
Dim ws As Worksheet
Set ws = Sheets("Data")
LastRow = ws.Cells(Rows.Count, "AK").End(xlUp).Row
For Each cell In Range("N5:R24")
If cell.Value <> "" Then
cell.Copy
Range("AK" & LastRow + 1).PasteSpecial xlPasteValues
End If
Next
End Sub

Answer 1

我认为以下代码会照顾您的目标。（我不确定B列是否附加到输出仅如果您正在处理N列，或者您是否正在处理N列所包含的行上的任何值＆＃34; BULK＆＃34;。我的代码执行后者，但我还包括一个注释掉的版本来完成前者。）

Dim cell As Range
Dim lastRow As Long
Dim newValue As String
Dim ws As Worksheet
Set ws = Sheets("Data")

With ws
    'Initialise lastRow to be the last used row in column T
    lastRow = .Cells(.Rows.Count, "T").End(xlUp).Row
    'Loop through every cell in the desired range
    For Each cell In .Range("N5:R24")
        'Start by setting the new value to be the old value
        newValue = cell.Value
        'Only process cells that aren't blank
        If newValue <> "" Then
            'Increment row counter for result
            lastRow = lastRow + 1
            'Check if column N contains "BULK"
            If UCase(Mid(.Cells(cell.Row, "N").Value, 2, 4)) = "BULK" Then
                'If it does, append the contents of column B
                newValue = newValue & "/" & .Cells(cell.Row, "B").Value
            End If
            ''Alternate version if ONLY values in column N need to have column B appended
            'If UCase(Mid(newValue, 2, 4)) = "BULK" And cell.Column = 14 Then
            '    'If it does, append the contents of column B
            '    newValue = newValue & "/" & .Cells(cell.Row, "B").Value
            'End If

            'Append "/CA"
            newValue = newValue & "/CA"
            'Store result in column T
            .Cells(lastRow, "T").Value = newValue
        End If
    Next
End With

Answer 2

For Each cell In Range("N5:R24")
If cell.Value <> "" Then
cell.Copy
Range("AK" & LastRow + 1).PasteSpecial xlPasteValues
Range("AK" & LastRow + 1).value = Range("AK" & LastRow + 1).value & "/CA"
LastRow = LastRow + 1
End If
Next

您还可以使用if子句实现其他条件。你也会用＆amp;相互联系。
你也必须在每个循环增加LastRow，否则它将保持不变。

复制范围内的非空白单元格并仅粘贴到一列

2 个答案: