将单元格（不包括空格）的范围复制到一个单元格中

我正在处理VBAmacros，它将检查列“S”中的标签“Tracker”中的string与列表，如果find匹配，它将跳过该行并移动到下一个。 如果列“S”中的string不在列表中，则它将复制范围（“U3：Y3”）到该活动“S”单元格的右侧，并将其粘贴到“报告”选项卡中的一个单元格中。

我成功地复制了范围，但它也包含空白的单元格，因此它给了我粘贴的单元格中不必要的空白空间。

Sub ImportData() 'Create array with Status type values Dim StatusList As Object Set StatusList = CreateObject("Scripting.Dictionary") StatusList.Add "Cancelled", 1 StatusList.Add "Postponed", 2 StatusList.Add "Rescheduled", 3 StatusList.Add "Rolled Back", 4 Dim StoresTotal As Long With Sheets("Tracker") 'Count cells containing values in row C StoresTotal = .Cells(Rows.count, "C").End(xlUp).Row StoresTotal = StoresTotal - 2 'removing 2 for header values 'MsgBox "value is " & StoresTotal End With 'Copy Status from the first cell Dim Status As String Sheets("Tracker").Select Range("S3").Activate Status = ActiveCell.Value 'MsgBox "value is " & Status Dim StatusLoopCounter As Integer StatusLoopCounter = 0 Dim SiteNamePos As Integer SiteNamePos = 8 Dim DevicesPos As Integer DevicesPos = 10 Dim DevicesUYRange As String Do Until StatusLoopCounter = StoresTotal 'open Status column check loop If StatusList.Exists(Status) Then 'IF exists in the list then skip to next row MsgBox "value is " & Status 'lower position and increase the counter Selection.Offset(1, 0).Select Status = ActiveCell.Value StatusLoopCounter = StatusLoopCounter + 1 Else 'IF does not exist in the list Worksheets("Reports").Range("A" & SiteNamePos).Value = Worksheets("Tracker").Range("C" & (ActiveCell.Row)).Value DevicesUYRange = Join(Application.Transpose(Application.Transpose(Range("U3:Y3").Value)), vbCrLf) Worksheets("Reports").Range("A" & DevicesPos).Value = DevicesUYRange MsgBox DevicesUYRange 'lower position and increase the counter Range("S" & (ActiveCell.Row)).Select Selection.Offset(1, 0).Select Status = ActiveCell.Value StatusLoopCounter = StatusLoopCounter + 1 End If Loop 'close Status column check loop 

结束小组

我想复制一系列不包含空格的单元格，并将所有数据以下列格式粘贴到一个单元格中。

我有一种感觉，我完全错了，请帮我摆脱范围select的空白单元格。 谢谢。

<<<<<编辑>>>>>添加以下扩展描述和完整的代码

也许如果我描述整个图片，你将能够帮助我对它进行sorting，也可能改善代码的性能。

跟踪器选项卡 ：我在一周内更新跟踪器选项卡，并检查项目可交付成果的状态。 每个星期五，我都必须发送一个报告，报告只包含成功执行的可交付成果的状态。

我跟踪在细胞（A1）中的下一周计划完成的可交付成果的总数。我跟踪在细胞B1中成功完成的可交付成果。 基本上排除了“推迟，取消，改期”等状态。

“报告”选项卡：在此选项卡中，我将创build包含包含一些概览通用数据的标题的每周报告。 在标题部分之后，我将为成功交付的数量生成单元“块”。 在我的例子中，将会是x10次。

我写了一个macros来创build和格式表，现在我正在寻找一个有效的方式来填充它。 我有3个操作button：

1. 创build表格 – 为已完成交付物的数量创build空的报告模板 – Sub Report_Table（）
2. 清除选项卡 – 擦除“报告”选项卡中的所有单元格 – Sub ClearReport（）
3. 导入数据 – 使用“跟踪器”选项卡中的数据填充报表 – Sub ImportData（）

导入数据：当我在“报告”选项卡中单击“导入数据”button时，macros将：

1. 转到Tracker选项卡并检查S列中第一个单元格的值，即S3。 如果单元格值与（取消，延期，重新计划，回滚）不同，则会将数据复制到报表的第一个块
2. 它将从Tracker选项卡单元格C3（站点ID）复制数据并粘贴到Reports选项卡单元格A15（站点名称）
3. 从范围U3：Y3复制设备名称，排除空白单元格
4. 并按照以下格式粘贴到“报告”选项卡单元格中的单个单元格
5. 如果是，请检查同一行的单元格R是否包含值
6. 从Tracker选项卡R复制评论到Reports选项卡打开项目
7. 然后在S列中向下移动一个位置，在列S中移动到相同的位置。

当需要创build一个额外的计数器下移位置粘贴数据时，如果我们粘贴到该行的第四个报告块，则应该向下移动并继续粘贴数据。

我对你的解决scheme的实现感到困惑，因为我完全不理解你的代码。

我有几个问题，我的代码如下：

Q1。 我是如何复制特定单元格的效率？ 我有一种感觉，有一个更简单的方法来做同一行的细胞。

Q2。 我的方法不错，先创build一个空的报告模板，然后用数据填充它？ 或者我应该寻找一种将性能和速度两者结合起来的方法？

@ user1274820请帮我实施你的解决scheme到我的代码中。 我的代码的所有评论/提示都是值得欢迎的，因为我还在学习。

谢谢。

跟踪器标签的一般视图：

生成表格模板（创build表格button）：

Sub Report_Table（）

昏暗的开始时间作为双昏暗SecondsElapsed为双

StartTime =计时器

 'Create report header table Range("A2:D5").Select Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = xlAutomatic .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = xlAutomatic .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = xlAutomatic .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .ColorIndex = xlAutomatic .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlInsideVertical) .LineStyle = xlContinuous .ColorIndex = xlAutomatic .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlInsideHorizontal) .LineStyle = xlContinuous .ColorIndex = xlAutomatic .TintAndShade = 0 .Weight = xlMedium End With With Selection .HorizontalAlignment = xlGeneral .VerticalAlignment = xlCenter .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With With Selection .HorizontalAlignment = xlLeft .VerticalAlignment = xlCenter .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With Range("A2:D2,A4:D4").Select Range("A4").Activate Selection.Font.Bold = True With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent1 .TintAndShade = 0.599993896298105 .PatternTintAndShade = 0 End With 'Populate header table [A2].Value = "Partner:" [A3].Value = "Partner name here" [A4].Value = "Number of Sites:" Sheets("Tracker").Range("B1").Copy Sheets("Reports").Range("A5").PasteSpecial xlPasteValues [B2].Value = "Scope:" [B3].Value = "FFF & TTP" [B4].Value = "Pods:" [B5].Value = "n/a" [C2].Value = "Sponsor:" [C3].Value = "Input sponsor name" [C4].Value = "Number of Devices:" Sheets("Tracker").Range("T1").Copy Sheets("Reports").Range("C5").PasteSpecial xlPasteValues [D2].Value = "Engineer:" [D3].Value = "n/a" [D4].Value = "PM:" [D5].Value = "PM name here" 'Create Report device table template blocks Range("A7:A12").Select Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = xlAutomatic .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = xlAutomatic .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = xlAutomatic .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .ColorIndex = xlAutomatic .TintAndShade = 0 .Weight = xlMedium End With Selection.Borders(xlInsideVertical).LineStyle = xlNone With Selection.Borders(xlInsideHorizontal) .LineStyle = xlContinuous .ColorIndex = xlAutomatic .TintAndShade = 0 .Weight = xlMedium End With With Selection .HorizontalAlignment = xlGeneral .VerticalAlignment = xlCenter .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With With Selection .HorizontalAlignment = xlLeft .VerticalAlignment = xlCenter .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With Range("A7,A9,A11").Select Range("A11").Activate Selection.Font.Bold = True With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent1 .TintAndShade = 0.599993896298105 .PatternTintAndShade = 0 End With [A7].Value = "Site Name:" [A9].Value = "Devices:" [A11].Value = "Open Items:" Range("A8,A10,A12").Select Range("A12").Activate With Selection .HorizontalAlignment = xlLeft .VerticalAlignment = xlCenter .WrapText = True .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With 'Assign Total number of deliverables Tracker-A1 Dim MigrationTotal As Integer MigrationTotal = Sheets("Tracker").Range("B1").Value Range("A7:A12").Select Selection.Copy 'MsgBox Selection.Column 'MsgBox "value is " & MigrationTotal Dim LoopCounter As Integer LoopCounter = 1 Do Until LoopCounter = MigrationTotal 'open column loop If Selection.Column >= 4 Then 'move one line below 'MsgBox Selection.Column Selection.Offset(0, 1).Select Selection.Offset(7, -4).Select ActiveSheet.Paste LoopCounter = LoopCounter + 1 Else Selection.Offset(0, 1).Select ActiveSheet.Paste LoopCounter = LoopCounter + 1 End If Loop 'close column loop Application.CutCopyMode = False 'MsgBox "value is " & MigrationTotal SecondsElapsed = Round(Timer - StartTime, 2) MsgBox "Report table completed in: " & SecondsElapsed & " seconds", vbInformation 

结束小组

清除button：

Sub ClearReport（）

范围（ “A1：H40”）清除。

结束小组

导入数据button：

Sub ImportData（）

 'Create array with Status type values Dim StatusList As Object Set StatusList = CreateObject("Scripting.Dictionary") StatusList.Add "Cancelled", 1 StatusList.Add "Postponed", 2 StatusList.Add "Rescheduled", 3 StatusList.Add "Rolled Back", 4 Dim StoresTotal As Long With Sheets("Tracker") 'Count cells containing values in row C StoresTotal = .Cells(Rows.count, "C").End(xlUp).Row StoresTotal = StoresTotal - 2 'removing 2 for header values 'MsgBox "value is " & StoresTotal End With 'Copy Status from the first cell Dim Status As String Sheets("Tracker").Select Range("S3").Activate Status = ActiveCell.Value 'MsgBox "value is " & Status Dim StatusLoopCounter As Integer StatusLoopCounter = 0 Dim SiteNamePos As Integer SiteNamePos = 8 Dim DevicesPos As Integer DevicesPos = 10 Dim DevicesUYRange As String Do Until StatusLoopCounter = StoresTotal 'open Status column check loop If StatusList.Exists(Status) Then 'IF exists in the list then skip to next row MsgBox "value is " & Status 'lower position and increase the counter Selection.Offset(1, 0).Select Status = ActiveCell.Value StatusLoopCounter = StatusLoopCounter + 1 Else 'IF does not exist in the list Worksheets("Reports").Range("A" & SiteNamePos).Value = Worksheets("Tracker").Range("C" & (ActiveCell.Row)).Value DevicesUYRange = Join(Application.Transpose(Application.Transpose(Range("U3:Y3").Value)), vbCrLf) Worksheets("Reports").Range("A" & DevicesPos).Value = DevicesUYRange MsgBox DevicesUYRange 'lower position and increase the counter Range("S" & (ActiveCell.Row)).Select Selection.Offset(1, 0).Select Status = ActiveCell.Value StatusLoopCounter = StatusLoopCounter + 1 End If Loop 'close Status column check loop 

结束小组

注：我知道我的屏幕截图被吹走了，不知道为什么，可能是因为笔记本电脑的分辨率是4k …我将重新上传，当我回家。

Answer 1

保持简单的朋友：

我们基本上说， For Each c In S3到S列的最后一行…

If Not StatusList.Exists则将跟踪器上最后一行的值设置为该范围的串联。

如果我们使用vbCrLf它会给我们一个像你最初显示的新行。

 Sub ImportData() 'Create array with Status type values Dim StatusList As Object Set StatusList = CreateObject("Scripting.Dictionary") StatusList.Add "Cancelled", 1 StatusList.Add "Postponed", 2 StatusList.Add "Rescheduled", 3 StatusList.Add "Rolled Back", 4 Dim c With Sheets("Tracker") For Each c In .Range("S3:S" & .Cells(Rows.CountLarge, "S").End(xlUp).Row) If Not StatusList.Exists(c.Value) Then 'Set Last Row of Report + 1 equal to 'A concatenation of non-blank cells and vbCrLf :) Sheets("Report").Range("A" & Sheets("Report").Cells(Rows.CountLarge, "A").End(xlUp).Row + 1).Value = _ Join(Application.Transpose(Application.Transpose(c.Offset(0, 2).Resize(, 5).SpecialCells(xlCellTypeConstants))), vbCrLf) End If Next c End With Set StatusList = Nothing End Sub 

input：

结果：