Ports
12-24-2018, 08:37 AM
Hi,
I'm new to VBA but not new to programming. Because I have some experience with other languages I can see that my code is far from good. There's a lot of duplication. I put it together by copy/pasting from online sources and/or googling some specific commands.
Would someone be able to help make it more concise or optimised:
Sub ValidateReturn()
DeleteFirstSheet
CreateSheet
CopyAims
FillBlanks
SplitLearnerDetails
End Sub
Sub SplitLearnerDetails()
Dim tw As Worksheet: Set tw = ThisWorkbook.Sheets("FundingReturn") 'target worksheet
tw.Activate
Range("A1").EntireColumn.Insert Shift:=xlToRight
Range("A1").EntireColumn.Insert Shift:=xlToRight
Range("A1").EntireColumn.Insert Shift:=xlToRight
Dim substrings() As String
Dim i As Long
lRow = Cells(Rows.Count, 4).End(xlUp).Row
For i = 1 To lRow
substrings = Split(Cells(i, 4), " - ")
Cells(i, 1).Value = substrings(0) & "-" & Cells(i, 5)
Cells(i, 2).Value = substrings(0)
Cells(i, 3).Value = substrings(1)
Next i
End Sub
Sub FillBlanks()
Dim lRow As Long
Dim tw As Worksheet: Set tw = ThisWorkbook.Sheets("FundingReturn") 'target worksheet
tw.Activate
'Find the last non-blank cell in column A(1)
'I think this needs to be changed to 1 below as we re not inserting it yet
lRow = Cells(Rows.Count, 2).End(xlUp).Row
'Iterate over Column A values
'If it's blank, take the value from the cell above
For i = 1 To lRow
If Cells(i, 1).Value = "" Then
Cells(i, 1).Value = Cells(i - 1, 1).Value
End If
Next i
End Sub
Sub CopyHeader()
Dim sw As Worksheet: Set sw = ThisWorkbook.Sheets("OriginalFunding") 'source worksheet
Dim tw As Worksheet: Set tw = ThisWorkbook.Sheets("FundingReturn") 'target worksheet
tw.Activate
'insert a blank row
tw.Range("A1").EntireRow.Insert
sw.Activate
Const WHAT_TO_FIND As String = "Learner"
Set FoundCell = sw.Range("A:A").Find(What:=WHAT_TO_FIND)
If Not FoundCell Is Nothing Then
sw.Rows(FoundCell.Row).EntireRow.Copy tw.Range("A1")
Else
MsgBox (WHAT_TO_FIND & " not found")
End If
End Sub
Sub DeleteFirstSheet()
'Check if the first sheet is called Sheet1
'If so, delete it.
Dim t As String
t = Sheets(1).Name
If t = "Sheet1" Then
Application.DisplayAlerts = False
Sheets(1).Delete
Application.DisplayAlerts = True
End If
Sheets(1).Name = "OriginalFunding"
End Sub
Private Sub CreateSheet()
Dim ws As Worksheet
With ThisWorkbook
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
ws.Name = "FundingReturn"
End With
End Sub
Sub CopyAims()
Dim i As Long
Dim vLastRow As Long
Dim s2 As Long
Dim sw As Worksheet: Set sw = ThisWorkbook.Sheets("OriginalFunding") '<-- Update
Dim tw As Worksheet: Set tw = ThisWorkbook.Sheets("FundingReturn") '<-- Update
'Activate the source sheet
sw.Activate
'find last row in sheet, or you could change to find last row in specified column
'Example: Cells = Columns(column number or letter), Cells(1, 1) = Cells(1, column number)
vLastRow = Cells.Find(What:="*", After:=Cells(1, 1), searchorder:=xlByRows, searchdirection:=xlPrevious).Row
s2 = 1
Application.ScreenUpdating = False
For i = 1 To vLastRow
If Trim(Len(CStr(Cells(i, 2)))) = 8 Then
Rows(i).EntireRow.Copy Destination:=tw.Range(Cells(s2, 1).Address)
s2 = s2 + 1
End If
Next i
Application.ScreenUpdating = True
End Sub
Thank you
I'm new to VBA but not new to programming. Because I have some experience with other languages I can see that my code is far from good. There's a lot of duplication. I put it together by copy/pasting from online sources and/or googling some specific commands.
Would someone be able to help make it more concise or optimised:
Sub ValidateReturn()
DeleteFirstSheet
CreateSheet
CopyAims
FillBlanks
SplitLearnerDetails
End Sub
Sub SplitLearnerDetails()
Dim tw As Worksheet: Set tw = ThisWorkbook.Sheets("FundingReturn") 'target worksheet
tw.Activate
Range("A1").EntireColumn.Insert Shift:=xlToRight
Range("A1").EntireColumn.Insert Shift:=xlToRight
Range("A1").EntireColumn.Insert Shift:=xlToRight
Dim substrings() As String
Dim i As Long
lRow = Cells(Rows.Count, 4).End(xlUp).Row
For i = 1 To lRow
substrings = Split(Cells(i, 4), " - ")
Cells(i, 1).Value = substrings(0) & "-" & Cells(i, 5)
Cells(i, 2).Value = substrings(0)
Cells(i, 3).Value = substrings(1)
Next i
End Sub
Sub FillBlanks()
Dim lRow As Long
Dim tw As Worksheet: Set tw = ThisWorkbook.Sheets("FundingReturn") 'target worksheet
tw.Activate
'Find the last non-blank cell in column A(1)
'I think this needs to be changed to 1 below as we re not inserting it yet
lRow = Cells(Rows.Count, 2).End(xlUp).Row
'Iterate over Column A values
'If it's blank, take the value from the cell above
For i = 1 To lRow
If Cells(i, 1).Value = "" Then
Cells(i, 1).Value = Cells(i - 1, 1).Value
End If
Next i
End Sub
Sub CopyHeader()
Dim sw As Worksheet: Set sw = ThisWorkbook.Sheets("OriginalFunding") 'source worksheet
Dim tw As Worksheet: Set tw = ThisWorkbook.Sheets("FundingReturn") 'target worksheet
tw.Activate
'insert a blank row
tw.Range("A1").EntireRow.Insert
sw.Activate
Const WHAT_TO_FIND As String = "Learner"
Set FoundCell = sw.Range("A:A").Find(What:=WHAT_TO_FIND)
If Not FoundCell Is Nothing Then
sw.Rows(FoundCell.Row).EntireRow.Copy tw.Range("A1")
Else
MsgBox (WHAT_TO_FIND & " not found")
End If
End Sub
Sub DeleteFirstSheet()
'Check if the first sheet is called Sheet1
'If so, delete it.
Dim t As String
t = Sheets(1).Name
If t = "Sheet1" Then
Application.DisplayAlerts = False
Sheets(1).Delete
Application.DisplayAlerts = True
End If
Sheets(1).Name = "OriginalFunding"
End Sub
Private Sub CreateSheet()
Dim ws As Worksheet
With ThisWorkbook
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
ws.Name = "FundingReturn"
End With
End Sub
Sub CopyAims()
Dim i As Long
Dim vLastRow As Long
Dim s2 As Long
Dim sw As Worksheet: Set sw = ThisWorkbook.Sheets("OriginalFunding") '<-- Update
Dim tw As Worksheet: Set tw = ThisWorkbook.Sheets("FundingReturn") '<-- Update
'Activate the source sheet
sw.Activate
'find last row in sheet, or you could change to find last row in specified column
'Example: Cells = Columns(column number or letter), Cells(1, 1) = Cells(1, column number)
vLastRow = Cells.Find(What:="*", After:=Cells(1, 1), searchorder:=xlByRows, searchdirection:=xlPrevious).Row
s2 = 1
Application.ScreenUpdating = False
For i = 1 To vLastRow
If Trim(Len(CStr(Cells(i, 2)))) = 8 Then
Rows(i).EntireRow.Copy Destination:=tw.Range(Cells(s2, 1).Address)
s2 = s2 + 1
End If
Next i
Application.ScreenUpdating = True
End Sub
Thank you