尝试复制过滤后的单元格，然后粘贴为在目标单元格中用逗号分隔的值以创建商业智能

Question

我的 Excel 看起来像这样

Project	Type	Business Intelligence
1001	Apples
1002	Oranges
1003	Oranges
1004	Bananas
1005	Apples
1006	Apples

因此，当我将“B”列过滤为只有苹果时，我希望能够将第 6 行（与项目 1006 内联）的 C 列（商业智能列）中的“1001、1005”粘贴到表明我们之前做过两次苹果。 值之间的逗号并不重要，即使 space 也行

阅读多篇文章后，我找到了最接近我的解决方案。

Option Explicit

Sub CopyToY()
    
    Dim ws As Worksheet: Set ws = ActiveSheet ' be more specific
    
    ' First Cell of the Data Range (in the row below headers)
    Dim fCell As Range: Set fCell = ws.Range("A2")
    ' Last Cell of the Filtered Range
    Dim lCell As Range: Set lCell = ws.Range("A" & ws.Rows.Count).End(xlUp)
    ' If no filtered data, the last cell will be the header cell, which
    ' is above the first cell. Check this with:
    If lCell.Row < fCell.Row Then Exit Sub ' no filtered data
    
    ' Range from First Cell to Last Cell
    Dim rg As Range: Set rg = ws.Range(fCell, lCell)
    
    ' Filtered Data Range
    Dim frg As Range: Set frg = rg.SpecialCells(xlCellTypeVisible)
    
    ' Area Range
    Dim arg As Range
    
    For Each arg In frg.Areas



        arg.EntireRow.Columns("Y").Value = arg.Value ' **this is where it all goes wrong for me - I don't want to paste in column Y but in C6 as "1001, 1005"**



    Next arg
    MsgBox "Filtered data copied to column ""Y"".", vbInformation
    
End Sub

现在正努力在 C6 中粘贴为值，而不是我发现此代码的 Y 列。

Sub JoinCells()

Set xJoinRange = Application.InputBox(prompt:="Highlight source cells to merge",    Type:=8)
xSource = 0
xSource = xJoinRange.Rows.Count
xType = "rows"
If xSource = 1 Then
    xSource = xJoinRange.Columns.Count
    xType = "columns"
End If
Set xDestination = Application.InputBox(prompt:="Highlight destination cell", Type:=8)
If xType = "rows" Then
    temp = xJoinRange.Rows(1).Value
    For i = 2 To xSource
        temp = temp & " " & xJoinRange.Rows(i).Value
    Next i
Else
    temp = xJoinRange.Columns(1).Value
    For i = 2 To xSource
        temp = temp & " " & xJoinRange.Columns(i).Value
    Next i
End If

xDestination.Value = temp

End Sub

但不幸的是，这段代码也采用了不可见的过滤行。这意味着我的 C6 值显示为 1001 1002 1003 1004 1005 1006

我想做的是取第一个代码的第一部分，自动取过滤后的A列（项目）的内容，然后使用第二个代码的第二部分，就可以粘贴答案了” C6 中的 1001、1005"（商业智能栏，与项目 1006 一致）- 这可以通过突出显示目标单元格或 甚至更好地自动选择 C 栏中的最后一个可见单元格

我不是程序员，从来没有学过编码，我只是运行我自己的事 - 尽我最大努力完成这件事，但不幸的是我无法成功合并这两个代码。

如有任何帮助，我们将不胜感激。

Answer 1

也许你想尝试这样的事情？

Sub test()
Dim rg As Range
Dim i As Integer
Dim cell As Range
Dim x As String

If ActiveSheet.FilterMode Then
Set rg = Range("B2", Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
If Application.CountA(rg) < 2 Then Exit Sub
i = 0

    For Each cell In rg
        i = i + 1
            If cell.Address = Range("B" & Rows.Count).End(xlUp).Address Then
                cell.Offset(0, 1).Value = x
            Else
                If i = 1 Then x = cell.Offset(0, -1) Else x = x & ", " & cell.Offset(0, -1)
            End If
    Next
    
End If
End Sub

上面的子不会在你每次过滤数据时自动运行，因为它需要在你过滤数据后手动运行。该代码也不进行错误检查（例如，如果您使用数据中不存在的条件过滤数据）。

首先代码检查活动 sheet 是否被过滤，如果是那么它设置可见的过滤数据范围（rg 变量）。如果该范围的计数大于 1，则过程：

循环到该范围内的每个单元格
如果是第一次循环，则取A列的值，循环后的cell.offset(0,-1)作为x变量
如果不是第一次循环，则将x的值加上","和A列的值，循环cell.offset(0,-1).
一旦循环单元格地址与rg可见数据的最后一行相同，则将x值写入可见数据最后一行的同一行C列。

仍然不确定这是否是您想要的。我想知道数据是否会增长或只是静态的。如果它会增长，（以你的苹果为例）C 列中是否会有两行，其中最后一行包含 1001 和 1005（之前宏的结果），最后一行包含 1001、1005 和 1006？

尝试复制过滤后的单元格，然后粘贴为在目标单元格中用逗号分隔的值以创建商业智能

Trying to copy filtered cells and then pasting as value seperating with a comma in a destination cell to create Business Intelligence

excel

vba

尝试复制过滤后的单元格，然后粘贴为在目标单元格中​​用逗号分隔的值以创建商业智能

Trying to copy filtered cells and then pasting as value seperating with a comma in a destination cell to create Business Intelligence

excel

vba

尝试复制过滤后的单元格，然后粘贴为在目标单元格中用逗号分隔的值以创建商业智能