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 stackoverflow.com/questions/10714251/… And here is an example on how i did something similar, it might not be the best way, however is simple: stackoverflow.com/questions/45588963/… — danieltakeshi
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
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
I posted a solution - if you have any issues with it, let me know :) — user1274820

user1274820 user1274820 · Accepted Answer · 2017-08-11T21:31:35

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:

Copy range of cells (excluding blanks) into one cell

1 Answers