堆栈内存溢出
  繁体   English   中英

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

[英]Copy range of cells (excluding blanks) into one cell

 原文  2017-08-11 20:39:46  6   1    vba/ excel

问题描述

我正在研究 VBA 宏，该宏将检查“S”列中“跟踪器”选项卡中的字符串和列表，如果找到匹配项，它将跳过该行并移至下一行。 如果“S”列中的字符串不在列表中，则它会将 Range("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
End Sub

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

在此处输入图片说明

我有一种感觉我完全错了，请帮我从范围选择中删除空白单元格。 谢谢。

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

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

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

我在单元格 (A1) 中跟踪计划下一周的总可交付成果的计数 我在单元格 B1 中跟踪成功完成的可交付成果。 基本上不包括状态为“推迟，取消，重新安排”等的总数。

在此处输入图片说明

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

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

  1. 创建表格 - 为已完成的可交付成果的数量创建空报告模板 - Sub Report_Table()
  2. 清除选项卡 - 清除报告选项卡中的所有单元格 - Sub ClearReport()
  3. 导入数据 – 使用来自“跟踪器”选项卡的数据填充报告 - Sub ImportData()

在此处输入图片说明

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

  1. 转到跟踪器选项卡并检查 S 列中第一个单元格的值，即 S3。 如果单元格值不同于（取消、推迟、重新安排、回滚），它会将数据复制到报告的第一个块在此处输入图片说明
  2. 它将从跟踪器选项卡单元格 C3（站点 ID）复制数据并粘贴到报告选项卡单元格 A15（站点名称） 在此处输入图片说明
  3. 从范围 U3:Y3 复制设备名称，不包括空白单元格在此处输入图片说明
  4. 并按以下格式粘贴到“报告”选项卡单元格中的单个单元格在此处输入图片说明
  5. 检查同一行的单元格 R 是否包含值，如果是在此处输入图片说明
  6. 将评论从跟踪器选项卡 R 复制到报告选项卡打开的项目在此处输入图片说明
  7. 然后在 S 列中向下移动一个位置，并将 S 列中的单元格数量移动到相同的位置。

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

我在实现您的解决方案时有些挣扎，因为我不完全理解您的代码。

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

一季度。 我复制特定单元格的方式有效吗？ 我有一种感觉，对于同一行的单元格，有一种更简单的方法。

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

@user1274820请帮助我将您的解决方案实施到我的代码中。 由于我仍在学习，因此对我的代码的所有评论/提示都非常受欢迎。

谢谢你。

Tracker 选项卡的一般视图： 在此处输入图片说明

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

Sub Report_Table()

    Dim StartTime As Double
    Dim SecondsElapsed As 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()

    Range("A1:H40").Clear

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...我回家后会重新上传。

1 个解决方案

解决方案1
 1  2017-08-11 21:31:35

保持简单的朋友：

我们基本上说， For Each c In S3中的For Each c In到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

输入：

输入

结果：

结果

暂无
暂无

声明:本站的技术帖子网页，遵循CC BY-SA 4.0协议，如果您需要转载，请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.

相关问题 Excel VBA - 从一系列单元格中复制并粘贴到一个单元格中 VBA代码可将一个单元格的条件格式复制到未指定的单元格范围 将单元格值复制到一系列单元格 将单元格范围转换为一个单元格 Macro Excel可根据单元格匹配将范围单元格从一张纸复制到另一张纸，如果不匹配，则跳过单元格 复制不包括空白单元格的范围 - 粘贴到另一个工作表 将值从工作表中的单元格复制到一系列单元格中 将单元格从一张纸复制到另一张纸，对范围内的所有单元格重复 如何在一张纸到另一张纸中的特定单元格的范围内复制单元格数据？ 如何使用VS 2008 VB将单元格或一系列单元格从一个Excel电子表格复制到另一个Excel电子表格
相关标签
 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM