将单元格范围（不包括空白）复制到一个单元格中-Java 学习之路

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

enter image description here

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

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

结束子

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

enter image description here

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

<<<<< EDIT >>>>> 在下面添加了扩展说明和完整代码

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

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

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

enter image description here

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

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

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

enter image description here

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

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

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

我对解决方案的实现有点挣扎，因为我完全不理解你的代码 .

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

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

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

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

谢谢 .

General view of Tracker tab:
enter image description here

Generate table template (Create Table button):

Sub Report_Table（）

Dim StartTime作为Double Dim SecondsElapsed With Double

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

结束子

Clear button:

Sub ClearReport（）

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

结束子

Import Data 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 ......当我回到家时我会重新上传 .

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

结果：

Results

回复于 2024-05-16T05:55:52+08:00

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

1 回答

相关问题