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".
here">
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.
here">
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.
here">
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()
here">
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
rel="nofollow noreferrer">
alt="enter image description here"> - 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
here"> - and paste to a single cell in Reports
tab cell in the following format
here"> - Check if the cell R at the same row
contains value, IF yes
here"> - Copy comment from Tracker tab R to
Reports tab Open Items
rel="nofollow noreferrer">
alt="enter image description here"> - 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:
rel="nofollow noreferrer">
alt="enter image description
here">
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.
No comments:
Post a Comment