Code:
Sub CopyAndMoveThisWorks()
Dim FName As Variant
FName = Application.GetOpenFilename("N:\SEEL\nsb 2\Reports - Monthly\NTP Performance Reports - Backup Data\2013-14\(*.xlsx), *.xlsx", Title:="Select File To Be Opened")
If FName = False Then
Exit Sub
Else
Workbooks.Open FName
End If
End Sub
Sub CWN()
Dim sh As Worksheet
Dim TxtRng As Range
Application.EnableEvents = False
For Each sh In Worksheets(Array("Starts", "Leavers (incl SSMA Prog)", "In-training", "Achievements"))
With sh
.Select
.Columns("A:A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
.Range("A2:A" & .Cells(Rows.Count, "B").End(xlUp).Row).Value = .Name
Set TxtRng = sh.Range("A1")
TxtRng.Value = "Category"
End With
Next sh
Application.EnableEvents = True
SG_MoveColumns ("Starts")
SG_MoveColumns ("Leavers (incl SSMA Prog)")
SG_MoveColumns ("In-training")
SG_MoveColumns ("Achievements")
ThisWorkbook.Activate
MsgBox "All done."
End Sub
Sub SG_MoveColumns(sSheetname As String)
Dim src As Worksheet 'NTP Performance Reports - Backup Data\2013-14\NTP Performance Report 2013-14 Period 6 September - Data.xlsx
Dim srcLastRow As Double
Dim srcLastCol As Double
Dim tgt As Worksheet 'Data in MAG Pivot Version Copy
Dim tgtLastRow As Double
Dim dest As Range
Dim i As Long
Dim x As Long
Dim sColLetter As String
Dim stgtColLetter As String
Dim bFoundCol As Boolean
' Switch screen updating back off
Application.ScreenUpdating = False
' Create objects to use
Set src = Worksheets(sSheetname) ' use sheet name passed in to the
srcLastRow = src.Cells(Rows.Count, 1).End(xlUp).Row
srcLastCol = src.Cells(1, Columns.Count).End(xlToLeft).Column
Set tgt = Workbooks("MAG Pivot Version.xlsm").Worksheets("Data")
tgtLastRow = tgt.Cells(Rows.Count, 2).End(xlUp).Row
' Selects the columns to be copied
myColumns = Array("Category", "Assignment id", "Trainee district desc", "Gender", "Age Band", "VQ Level", "Updated programme", "Provider", "Updated Employer")
' Search the source worksheet to find the columns that the required field are in
For i = 0 To UBound(myColumns)
On Error Resume Next
' search the column headers - assume that held in row 1
' set the flag to NOT FOUND
bFoundCol = False
For x = 1 To srcLastCol
On Error Resume Next
If Trim(UCase(myColumns(i))) = Trim(UCase(src.Cells(1, x).Text)) Then
bfound = True
' convert the column number in to a column letter
sColLetter = Col_Letter(x)
' convert the array to the target column letter
stgtColLetter = Col_Letter(i + 1)
' copy of the column data
'Range(sColLetter is the column reference & "2" is the row of that column i.e. 2 omits the header
src.Range(sColLetter & "2:" & sColLetter & srcLastRow).Copy tgt.Range(stgtColLetter & tgtLastRow + 1)
Exit For
End If
Next x
Next i
'Tidy-up created objects
Set src = Nothing
Set tgt = Nothing
' Switch screen updating back on
Application.ScreenUpdating = True
End Sub
Function Col_Letter(lngCol As Long) As String
Dim vArr
' calculate the letter linked to the column
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
' return the letter
Col_Letter = vArr(0)
End Function
This is the fruits of my labour for too many days and Im now at the last wee bit. I just want the columns to now paste over to the MAG Pivot file.
Can someone please point out the reason why its not doing so?
Oh, and why isnt the folder path working? It just goes to whatever the last folder opened was.
Thanks in advance