Excel VBA從列復制值並將值粘貼到單元格中

Question

我有如下數據。 第一列屬於列A，第二列屬於列B。

1   q
1   q
2   q
2   q
2   q
3   q

我想在A列中的值更改時插入空行。 要插入行，我正在使用此站點中的宏。

'select column a before running the macro
Sub InsertRowsAtValueChange()
'Update 20140716
Dim Rng As Range
Dim WorkRng As Range
On Error Resume Next
xTitleId = "KutoolsforExcel"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)

Application.ScreenUpdating = False
For i = WorkRng.Rows.Count To 2 Step -1
    If WorkRng.Cells(i, 1).Value <> WorkRng.Cells(i - 1, 1).Value Then
        WorkRng.Cells(i, 1).EntireRow.Insert
    End If
Next
Application.ScreenUpdating = True
End Sub

之后，我想復制A列中的每組值並粘貼到C列中的單元格中。粘貼它們時，我想以行格式（通過連接它們）將值粘貼到單元格中，並用空間 。 在以下情況下，單元格c1應該具有1 1 ，單元格c4應該具有2 2 2並且單元格c8應該具有3

這個怎么做？ 我嘗試通過先復制每組值然后在轉置為一行后粘貼它們來記錄宏。 但是我很難再次復制值並將其粘貼到單個單元格中

Answer 1

我有此功能，類似於內置的Concatenate() ，但為您提供了過濾功能。 我似乎沒有完全幫助您，您可能會給您另一種實現最終目標的方法。

Function ConcatenateIf(CriteriaRange As Range, Condition As Variant, _
        ConcatenateRange As Range, Optional Separator As String = ",") As Variant
    Dim i As Long
    Dim strResult As String
    On Error GoTo ErrHandler
    If CriteriaRange.Count <> ConcatenateRange.Count Then
        ConcatenateIf = CVErr(xlErrRef)
        Exit Function
    End If
    For i = 1 To CriteriaRange.Count
        If CriteriaRange.Cells(i).Value = Condition Then
            strResult = strResult & Separator & ConcatenateRange.Cells(i).Value
        End If
    Next i
    If strResult <> "" Then
        strResult = Mid(strResult, Len(Separator) + 1)
    End If
    ConcatenateIf = strResult
    Exit Function
ErrHandler:
    ConcatenateIf = CVErr(xlErrValue)
End Function

Answer 2

下面的代碼行如下：

---

Option Explicit

Sub InsertRowsAtValueChange()
    Dim rng As Range, itms As Variant, cel As Range, i As Long, firstRow As Long

    Set rng = Range("A3:A1000")
    firstRow = rng.Row - 1

    Application.ScreenUpdating = False
    For i = rng.Rows.Count To 1 Step -1
        If rng.Cells(i, 1).Value2 <> rng.Cells(i - 1, 1).Value2 Then
            If i < rng.Row - 1 Then
                Set cel = rng(i, 1)
            Else
                rng.Cells(i, 1).EntireRow.Insert
                Set cel = rng(i + 1, 1)
            End If
            With cel.CurrentRegion
                itms = .Columns(1)
                If .Columns(1).Rows.Count > 1 Then itms = Join(Application.Transpose(itms))
                cel.Offset(0, 2) = itms
            End With
        End If
        If i = 1 Then Exit For
    Next
    Application.ScreenUpdating = True
End Sub

---