Copy range of cells (excluding blanks) into one cell

Question

I am working on VBA macro that will check string in Tab "Tracker" in column "S" with list, if match is found it will skip that row and move to the next. If string in column "S" is not on the list, it will then copy Range("U3:Y3") to the right of that active "S" cell and paste it to the one cell in Tab "Report".

I manage to copy successfully the range, but it also contain cells that are blank therfore it give me unnecesary empty space in cell I am pasting to.

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

I want to copy a range of cells excluding blanks and paste all the data into one cell in the following format.

I have a feeling I am doing it completely wrong, please help me get rid of the blank cells from range selection. Thanks.

<<<<< EDIT >>>>> Added below extended description and full code

Maybe if I describe the whole picture you will be able to help me get it sorted, possibly improving the code performance as well.

Tracker tab.
I update the Tracker tab during a week and check the status of project deliverables. Every Friday I have to send out a report that contain statuses of successfully executed deliverables only.

I track count of total deliverables scheduled for the following week in cell (A1) I track successfully completed deliverables in cell B1. Basically excluding from total count the ones with status “postponed, cancelled, rescheduled” etc.

Reports tab:.
In this tab I will create a weekly report including header containing some overview generic data. After header section I will generate cells “blocks” for the number of successful deliverables. In my example case that will be x10 times.

I wrote a macro to create and format the table, now I am looking for an efficient way to populate it. I have 3 operational buttons:

Create Table – to create empty report template for the number of completed deliverables - Sub Report_Table()
Clear Tab – to wipe all the cells in Reports tab - Sub ClearReport()
Import Data – to populate the report with data from “Tracker” tab - Sub ImportData()

Importing Data: When I click “Import Data” button in Reports tab, the macro will then:

Go to Tracker tab and check the value of first cell in column S, that is S3. IF the cell value is different than (Cancelled, Postponed, Rescheduled, Rolled Back) it will copy data to the first block of the report
It will copy data from Tracker tab cell C3 (Site ID) and paste to Reports tab cell A15 (Site Name)
Copy Device names from range U3:Y3 excluding blank cells
and paste to a single cell in Reports tab cell in the following format
Check if the cell R at the same row contains value, IF yes
Copy comment from Tracker tab R to Reports tab Open Items
Then move one position down in S column and to the same for the number of cells in column S.

There is a need to create an extra counter to move down position for pasting data when, If we pasted to 4th report block in that row row, It should then move down and continue pasting data.

I struggle a bit with implementation of your solution, as I don’t understand your code fully.

I have a few questions to my code below:

Q1. Is the way I copy specific cells efficient ? I have a feeling there is a simpler way to do it for cells at the same row.

Q2. Is my approach good, to create an empty report template first and later populate it with data? or should I look for a way to combine both actions for performance and speed ?

@user1274820 Please help me to implement your solution into my code. Also all the comments/hints for my code are more than welcome, as I am still learning.

Thank you.

General view of Tracker tab:

Generate table template (Create Table button):

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

Clear button:

Sub ClearReport()

    Range("A1:H40").Clear

End Sub

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

End Sub

NOTE: I know my screenshots are blown away, not sure why, probably because of Laptop resolution is 4k... I will reupload when I'm back home.

One way to remove Blanks is using If is different from Blank: `If .Cells(Rows, Columns) <> "" Then Action_something` And Refer to this so you avoid using `.Select/.Activate/Selection/Activecell/Activesheet/Acti‌vewor‌kbook` https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba And here is an example on how i did something similar, it might not be the best way, however is simple: https://stackoverflow.com/questions/45588963/split-a-single-row-of-data-into-multiple-unique-rows-into-a-new-sheet-to-include/45590339#45590339 — danieltakeshi, Aug 11 '17 at 20:44
Just curious - why do you want to put all that in a single cell? If you plan on doing any analysis or such with it later, that might cause headaches. Perhaps can you place the data into a new range, then format it so it looks like one cell? (I.e. border, white background, etc)? — BruceWayne, Aug 11 '17 at 20:55
do not use `Select ... Selected` in your code, it is sure to cause problems. .... use `Status = Sheets("Tracker").Range("S3").Value` you used it absolutely correctly after the `Else` statement and then something happened and you used `select` again — jsotola, Aug 11 '17 at 21:09
Excel 2016 has [TEXTJOIN function](https://support.office.com/en-us/article/TEXTJOIN-function-357b449a-ec91-49d0-80c3-0e8fc845691c) — Slai, Aug 11 '17 at 21:57
I posted a solution - if you have any issues with it, let me know :) — user1274820, Aug 11 '17 at 22:02
@user1274820 I just updated my post to include all the details, as I struggle to implement your solution into my code. Hope you can help me again. Thanks :) — Omen, Aug 18 '17 at 13:44

user1274820 · Answer 1 · 2017-08-11T21:53:38.313

1

Keep it simple friend:

We basically say, For Each c In S3 to the last row in column S...

If Not StatusList.Exists then set the value of the last row on tracker to a concatenation of the range.

If we use vbCrLf it will give us a new line like you showed originally.

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:

edited Aug 11 '17 at 21:53

answered Aug 11 '17 at 21:31

user1274820

7,786
3
37
74

1

Thank you so much for your help to solve my problem. I have hard time implementing your code into my file, as it's to advance for my current VBA knowledge, but I checked your code on a new document and it works like a charm :) Would you mind helping me implementing the changes into my full code ? I could share the file also for the code review. Thanks again for your help. – Omen Aug 18 '17 at 10:09
Are your sheet names correct? The code searches `Sheets("Tracker")` and `S3:S[LastRow]` It then sticks it on the last row of the `Report` sheet (`Sheets("Reports")`) - Unless you have an issue there, it's relatively straightforward and shouldn't give you issue. Are there formulas in the cells you are using? What's not working and what's happening when you run it? Also, if you want your table/code in general to be faster, add `Application.ScreenUpdating = False` to the beginning of the macro and `Application.ScreenUpdating = True` to the end - speeds things up considerably. – user1274820 Aug 18 '17 at 15:57

Copy range of cells (excluding blanks) into one cell

1 Answers1