堆棧內存溢出
  簡體   English   中英

將單元格范圍（不包括空格）復制到一個單元格中

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

 原文  2017-08-11 20:39:46  2   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