Question

我正在研究VBA宏，它会检查列表“S”中Tab“Tracker”中的字符串，如果找到匹配，它将跳过该行并移动到下一行。如果列“S”中的字符串不在列表中，则它会将Range（“U3：Y3”）复制到该活动“S”单元格的右侧，并将其粘贴到Tab“Report”中的一个单元格。

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

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

End Sub

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

我有一种感觉我完全错了，请帮我摆脱范围选择中的空白细胞。感谢。

＆LT;＆LT;＆LT;＆LT;＆LT;编辑＆gt;＆gt;＆gt;＆gt;＆gt;＆gt; 添加以下扩展说明和完整代码

也许如果我描述整个图片，您将能够帮助我对其进行排序，也可以提高代码性能。

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

我在单元格（A1）中跟踪下一周安排的总可交付成果数我在单元格B1中跟踪已成功完成的可交付成果。基本上从总数中排除那些状态为“推迟，取消，重新安排”等的

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

我写了一个宏来创建和格式化表，现在我正在寻找一种有效的方法来填充它。我有3个操作按钮：

创建表格 - 为已完成的可交付成果数创建空报告模板 - Sub Report_Table（）
清除标签 - 清除“报告”标签中的所有单元格 - Sub ClearReport（）
导入数据 - 使用“跟踪器”选项卡中的数据填充报表 - Sub ImportData（）

导入数据：当我单击“报告”选项卡中的“导入数据”按钮时，宏将显示：

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

如果我们粘贴到该行中的第4个报告块，则需要创建一个额外的计数器来向下移动位置以粘贴数据。然后它应该向下移动并继续粘贴数据。

我为解决方案的实施而苦苦挣扎，因为我完全不理解您的代码。

我在下面的代码中有几个问题：

Q1。我复制特定细胞的方式是否有效？我觉得有一种更简单的方法可以为同一行的细胞做到这一点。

Q2。我的方法是否良好，首先创建一个空的报告模板，然后用数据填充它？或者我应该寻找一种方法来结合性能和速度的两个动作？

@ user1274820 请帮我在我的代码中实施您的解决方案。此外，我的代码的所有评论/提示都非常受欢迎，因为我还在学习。

谢谢。

“跟踪器”标签的常规视图：

生成表格模板（创建表格按钮）：

Sub Report_Table（）

Dim StartTime As Double Dim SecondsElapsed With Double

StartTime = Timer

'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

End Sub

清除按钮：

Sub ClearReport（）

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

End Sub

导入数据按钮：

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

End Sub

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

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

0 个答案: