复制包含文本的单元格

Question

数据从 web-form 传输到 Excel。并非每个细胞都接收输入。单元格很多，扫描每个单元格查找文本非常耗时。

如何让文本自动从 sheet1 复制到 sheet2。但我不希望单元格以与原始 sheet 相同的布局显示。我希望将它们组合在一起，消除中间的所有空单元格。我还想从包含文本的行中获取标题。

我找到了这个宏：

Sub CopyC()  
Dim SrchRng As Range, cel As Range  
Set SrchRng = Range("C1:C10")  
For Each cel In SrchRng  
    If cel.Value <> "" Then  
        cel.Offset(2, 1).Value = cel.Value  
    End If  
Next cel

它只抓取包含文本的单元格，但它以与找到它时完全相同的布局显示它。任何帮助将不胜感激，并在未来为我节省大量扫描时间，提前致谢:)

Answer 1

我想这就是您要找的：

Sub CopyNonBlankCells()
    Dim cel As Range, myRange As Range, CopyRange As Range

    Set myRange = Sheet1.Range("C1:C20")    '---> give your range here

    For Each cel In myRange
        If Not IsEmpty(cel) Then
            If CopyRange Is Nothing Then
                Set CopyRange = cel
            Else
                Set CopyRange = Union(CopyRange, cel)
            End If
        End If
    Next cel

    CopyRange.Copy Sheet2.Range("C1")    '---> enter desired range to paste copied range without blank cells
End Sub

以上代码会将 Sheet1 中的范围 C1:C20 复制到 Sheet2

中的 C1

从 here 得到这个。

编辑：以下答案基于您的评论 ________________________________________________________________________________

如果你会像下面这样写

Set myRange = Sheet1.Range("G:G") 
Set myRange = Sheet2.Range("G:G")

myRange 将首先设置为 Sheet1.Range("G:G")，然后设置为 Sheet2.Range("G:G")，这意味着 myRange 的当前范围是 Sheet2.Range("G:G").

如果你想使用多个范围，你可以使用 UNION 函数，但使用 UNION 有一个限制，你可以组合不同的范围，但只能组合一个 sheet。您的要求是合并来自不同 sheet 的范围。为此，我添加了一个新作品 sheet 并将所有 sheet 中的 G:G 范围添加到其中。然后在使用新添加的 sheet 之后我将其删除。

以下代码将在名为 Result 的 sheet 中为您提供所需的输出。

Sub CopyNonBlankCells()
    Dim cel As Range, myRange As Range, CopyRange As Range

    Dim wsCount As Integer, i As Integer
    Dim lastRow As Long, lastRowTemp As Long
    Dim tempSheet As Worksheet

    wsCount = Worksheets.Count    '--->wsCount will give the number of Sheets in your workbook

    Set tempSheet = Worksheets.Add    '--->new sheet added
    tempSheet.Move After:=Worksheets(wsCount + 1)

    For i = 1 To wsCount 
        If Sheets(i).Name <> "Result" Then    '---> not considering sheet "Result" for taking data
            lastRow = Sheets(i).Cells(Rows.Count, "G").End(xlUp).Row    '--->will give last row in sheet
            lastRowTemp = tempSheet.Cells(Rows.Count, "G").End(xlUp).Row    '--->will give last row in newly added sheet
            Sheets(i).Range("G1:G" & lastRow).Copy _
            tempSheet.Range("G" & lastRowTemp + 1).End(xlUp)(2)
        End If
    Next i

    lastRowTemp = tempSheet.Cells(Rows.Count, "G").End(xlUp).Row
    Set myRange = tempSheet.Range("G1:G" & lastRowTemp)    '--->setting range for removing blanks cells

    For Each cel In myRange
        If Not IsEmpty(cel) Then
            If CopyRange Is Nothing Then
                Set CopyRange = cel
            Else
                Set CopyRange = Union(CopyRange, cel)
            End If
        End If
    Next cel

    CopyRange.Copy Sheets("Result").Range("G1")    '---> enter desired range to paste copied range without blank cells

    Application.DisplayAlerts = False
    tempSheet.Delete        '--->deleting added sheet
    Application.DisplayAlerts = True
End Sub

Answer 2

你可以使用数组！

您可以先将所有信息存储在一个数组中，然后在另一个 sheet 上打印该数组，而不是将信息从一个单元格复制到另一个单元格。您可以告诉数组避免出现空单元格。通常，使用数组是存储信息的最佳方式。（通常是处理信息的最快方式）

如果您只查看一列，则可以使用一维数组。如果您正在查看多列，并希望将信息打印到另一页的相应列（但不同的单元格）中，那么您可以使用多维数组来存储您想要的其他列 number/anything。

根据您的代码，它可能如下所示：

Sub CopyC()  
Dim SrchRng As Range, cel As Range 

'Declare your 1-d array (I don't know what you are storing)
Dim myarray() as variant 
Dim n as integer
Dim i as integer

Set SrchRng = Range("C1:C10")
'define the number of elements in the array - 1 for now, increase it as we go
n = 0
Redim myarray(0 to n)

For Each cel In SrchRng  
    If cel.Value <> "" Then
        'redim preserve stores the previous values in the array as you redimension it
        Redim Preserve myarray(0 to n)
        myarray(n) = cel.Value  
        'increase n by 1 so next time the array will be 1 larger
        n = n + 1
    End If  
Next cel

'information is now stored, print it out in a loop
'this will print it out in sheet 2 providing it is called "Sheet2"
For i = 0 to ubound(myarray)
    Sheets("Sheet2").cells(i,1).value = myarray(i)
Next i

复制包含文本的单元格

copy cell if it contains text

excel

vba

copy

cells