Hi Everyone
I need some help please on a VBA script I've done for copying over data from four separate tabs in a workbook into one single tab.
The spreadsheet containing the script is linking data from a bog standard report which is downloaded from a BI system. There are four tabs from where the data is being copied from: each tab is basically mapping each cell from that BI report using IF(ISBLANK("BI Report"A2). So there's a lot of blanks (but with IF(ISBLANK) formulas in them). Each respective tab then uses a UNIQUE function to tidy all that data up, which is where the range of data is trying to be copied, then pasted into the 'Working Table'. So on some days, a tab may have 21 lines, on the other days, it may have only 1 line.
The script works perfectly fine when there's more than 1 line, but it doesn't work when:
1) there is no data in the starting cell, and / or,
2) there is only one line of data in the starting cell.
That's partly because of the way the script is written: go all the way across to the last column with data, then all the way down with the last row of data.
I'm not the best when it comes to Macros and VBA, but I was hoping if someone could please help me code this script in a way where:
1) If the starting cell in any of the four tabs is blank (e.g. if AG4 in "Cancellations" is blank), skip to the next tab
2) If there is only one line of data in the starting cell, select everything in that one row to the end of the range then move to the next tab
My script is as follows (it's a continuous script), with the problem part of the script marked. Maybe it should have been segregated better with separated tabs, but as you can see, I'm not the best with macros.
I'd really appreciate any help please? Thanks so much in advance.
I need some help please on a VBA script I've done for copying over data from four separate tabs in a workbook into one single tab.
The spreadsheet containing the script is linking data from a bog standard report which is downloaded from a BI system. There are four tabs from where the data is being copied from: each tab is basically mapping each cell from that BI report using IF(ISBLANK("BI Report"A2). So there's a lot of blanks (but with IF(ISBLANK) formulas in them). Each respective tab then uses a UNIQUE function to tidy all that data up, which is where the range of data is trying to be copied, then pasted into the 'Working Table'. So on some days, a tab may have 21 lines, on the other days, it may have only 1 line.
The script works perfectly fine when there's more than 1 line, but it doesn't work when:
1) there is no data in the starting cell, and / or,
2) there is only one line of data in the starting cell.
That's partly because of the way the script is written: go all the way across to the last column with data, then all the way down with the last row of data.
I'm not the best when it comes to Macros and VBA, but I was hoping if someone could please help me code this script in a way where:
1) If the starting cell in any of the four tabs is blank (e.g. if AG4 in "Cancellations" is blank), skip to the next tab
2) If there is only one line of data in the starting cell, select everything in that one row to the end of the range then move to the next tab
My script is as follows (it's a continuous script), with the problem part of the script marked. Maybe it should have been segregated better with separated tabs, but as you can see, I'm not the best with macros.
I'd really appreciate any help please? Thanks so much in advance.
VBA Code:
Sub copy_Data()
'
' copy_Data Macro
' This part of the macro copies the data from the Cancellations, T15, Worst T3, and Shortforms tabs.
CarryOn = MsgBox("Have you checked the Worst T3 tab to ensure there is a minimum of two trains for T3 failures (and are you happy with the fails limit)?", vbYesNo, "T3 Limits")
If CarryOn = vbYes Then
Application.ScreenUpdating = False
Sheets("Working Table").Select
Range("A5").Select
' PROBLEM STARTS FROM HERE
Sheets("Cancellations").Select
Range("AG4").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown).Offset(-1, 0)).Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("Working Table").Select
Range("A5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A5").Select
Range("A5").End(xlDown).Offset(1, 0).Select
Sheets("T15").Select
Range("O5").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown).Offset(-1, 0)).Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("Working Table").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A5").Select
Range("A5").End(xlDown).Offset(1, 0).Select
Sheets("Worst T3").Select
Range("N5").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("Working Table").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A5").Select
Range("A5").End(xlDown).Offset(1, 0).Select
Sheets("Shortforms").Select
Range("C4").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("Working Table").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A5").
' PROBLEM ENDS HERE
' Filtering Macro
' This part of the macro filters based on Train and Start Times.
ActiveWorkbook.Worksheets("Working Table").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Working Table").AutoFilter.Sort.SortFields.Add2 Key _
:=Range("A4"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Working Table").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWorkbook.Worksheets("Working Table").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Working Table").AutoFilter.Sort.SortFields.Add2 Key _
:=Range("B4"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Working Table").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' MergeCells
' This part of the macro merges the cells based on duplicates in the Trains Column and the Start Times.
Dim rng As Range, xCell As Range, WorkRng As Range
Dim xRows As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set WorkRng = ActiveWorkbook.ActiveSheet.Range("A1:A250, C1:C250")
xRows = WorkRng.Rows.Count
For Each rng In WorkRng.Columns
For i = 1 To xRows - 1
For j = i + 1 To xRows
If rng.Cells(i, 1).Value <> rng.Cells(j, 1).Value Then
Exit For
End If
Next
With WorkRng.Parent.Range(rng.Cells(i, 1), rng.Cells(j - 1, 1))
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
i = j - 1
Next
Next
' Unmerge top cells
' This part of the macro unmerges the cells in the top part of the workbook.
Range("A1:I3").Select
Range("I3").Activate
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 = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.UnMerge
' deldate Macro
' This macro deletes the populated cell in A1
Range("A1").Select
Selection.ClearContents
' datemacro Macro
' This macro produces a drop down for the date and day to be displayed.
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=DATE"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
Range("A3").Select
ActiveCell.FormulaR1C1 = "=IF(ISBLANK(RC[1]),"""",RC[1])"
Range("B3").Select
Selection.NumberFormat = "d-mmm"
' Highlight Date Cell
' This part of the macro highlights the date cell as a reminder that the date needs populating.
Range("B3").Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=LEN(TRIM(B3))=0"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 8420607
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
' Add border to table in range
Range("I4").Select
Range("I4", Range("I1000").End(xlUp)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
ActiveWindow.SmallScroll Down:=-48
Range("I4").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWindow.SmallScroll Down:=3
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
ActiveWindow.LargeScroll ToRight:=-1
ActiveWindow.SmallScroll Down:=-51
Range("A5").Select
End If
End Sub
