How do I amend the following code to work from the tgt workbook?

M

Mr Denove

Active Member
Joined
Jun 8, 2007
Messages
446
Code: 
Sub Test()
    
    SG_MoveColumns ("Starts")
    SG_MoveColumns ("Leavers (incl SSMA Prog)")
    SG_MoveColumns ("In-training")
    SG_MoveColumns ("Achievements")

End Sub

Sub SG_MoveColumns(sSheetname As String)

    Dim src As Worksheet
    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 Copy.xlsx").Worksheets("Data")
    tgtLastRow = tgt.Cells(Rows.Count, 2).End(xlUp).Row

    ' Selects the columns to be copied
    myColumns = Array("Status", "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

The above code currently works from the src workbook but this will change month on month and makes sense to move it to the tgt workbook.

Can someone please advise how I amend the code to to do this as its causing me problems?
Also need to find a way of adding the worksheets "Starts" etc to be copied over with the relevan data?
Thanks in advance
 
Sort by date Sort by votes
Code: 
Sub Test()
    Dim FName As Variant
    FName = Application.GetOpenFilename(FileFilter:="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
    ActiveWorkbook.Names.Add Name:=(FName), RefersTo:=Selection
       Else
        End If
    SG_MoveColumns ("Starts")
    SG_MoveColumns ("Leavers (incl SSMA Prog)")
    SG_MoveColumns ("In-training")
    SG_MoveColumns ("Achievements")
End Sub

Sub SG_MoveColumns(sSheetname As String)

    Dim tgt As Worksheet
    Dim tgtLastRow As Double
    Dim tgtLastCol As Double
    Dim src As Worksheet     '
    Dim srcLastRow 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
    Dim Workbook As ThisWorkbook
      
    ' Switch screen updating back off
    Application.ScreenUpdating = False

    ' Create objects to use
      
    Set src = ActiveWorkbook(FName).Worksheets(sSheetname)
    'src = Workbooks(FName).Worksheets(sSheetname)  ' use sheet name passed in to the inputbox
    srcLastRow = src.Cells(Rows.Count, 2).End(xlUp).Row
        
      
    'ThisWorkbook.Worksheet("Data").Activate
    Set tgt = ThisWorkbook.Sheets("Data")
    tgtLastRow = tgt.Cells(Rows.Count, 1).End(xlUp).Row
    tgtLastCol = tgt.Cells(1, Columns.Count).End(xlToLeft).Column
    
    
    
    ' Selects the columns to be copied
    myColumns = Array("Status", "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 tgtLastCol
            On Error Resume Next
            
                If Trim(UCase(myColumns(i))) = Trim(UCase(tgt.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
                    tgt.Range(sColLetter & "2:" & sColLetter & tgtLastRow).Copy src.Range(ssrcColLetter & srcLastRow + 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

Ok this is the code that I have to admit has been tampered with a fair bit.

I am still getting an error on

**Set src = ActiveWorkbook(FName).Worksheets(sSheetname)**
as the FName is not picking up the reference passed to it from the getopenfile.
I can carry on banging my head against a wall or can I ask if someone can look over this and give specfic changes etc as required for this to work.
Thanks in advance.
 
Upvote 0

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.
Shouldn't this:

Code: 
ActiveWorkbook.Names.Add Name:=(FName), RefersTo:=Selection

be?

Code: 
Workbooks.Open FName

I don't know why you've amended my code to add a name rather than opening the workbook.
 
Upvote 0
I haven't told you to write this:

Code: 
Set src = ActiveWorkbook(FName).Worksheets(sSheetname)

I told you to write:

Code: 
Set src = Workbooks(ActiveWorkbook.Name).Worksheets(sSheetname)

but as I said before I think that your original code should work:

Code: 
Set src = Worksheets(sSheetname)
 
Upvote 0
Neither of the two suggestions above have worked.

Still getting Runtime error 9

When I highlight the (ActiveWorkbookName) its showing as the Macro Pivot file i.e. the file where the macro is stored and where the data is going to, rather than the FName which is the source file
 
Upvote 0
Please post your entire code as it stands now and say where you have put it. Are you sure that the active workbook contains a worksheet whose name is the value assigned to sSheetname?
 
Upvote 0
Code: 
Sub Test()
    Dim FName As Variant
    FName = Application.GetOpenFilename(FileFilter:="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
    Workbooks.Open FName
       Else
        End If
    SG_MoveColumns ("Starts")
    SG_MoveColumns ("Leavers (incl SSMA Prog)")
    SG_MoveColumns ("In-training")
    SG_MoveColumns ("Achievements")
End Sub

Sub SG_MoveColumns(sSheetname As String)

    Dim tgt As Worksheet
    Dim tgtLastRow As Double
    Dim tgtLastCol As Double
    Dim src As Worksheet     '
    Dim srcLastRow 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
    Dim Workbook As ThisWorkbook
      
    ' Switch screen updating back off
    Application.ScreenUpdating = False

    ' Create objects to use
      
    Set src = Workbooks(ActiveWorkbook.Name).Worksheets(sSheetname)
    'src = Workbooks(FName).Worksheets(sSheetname)  ' use sheet name passed in to the inputbox
    srcLastRow = src.Cells(Rows.Count, 2).End(xlUp).Row
        
      
    'ThisWorkbook.Worksheet("Data").Activate
    Set tgt = ThisWorkbook.Sheets("Data")
    tgtLastRow = tgt.Cells(Rows.Count, 1).End(xlUp).Row
    tgtLastCol = tgt.Cells(1, Columns.Count).End(xlToLeft).Column
    
    
    
    ' Selects the columns to be copied
    myColumns = Array("Status", "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 tgtLastCol
            On Error Resume Next
            
                If Trim(UCase(myColumns(i))) = Trim(UCase(tgt.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
                    tgt.Range(sColLetter & "2:" & sColLetter & tgtLastRow).Copy src.Range(ssrcColLetter & srcLastRow + 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

The active workbook ie FName is picking up the file passed to it from GetOpenFileName but its not passing it onto the line I highlighed only the sheetname is showing when highlighted.
 
Upvote 0
This isn't right (or like I posted):

Code: 
    If FName = False Then
        Exit Sub
    Workbooks.Open FName
       Else
        End If

It should be:

Code: 
    If FName = False Then
        Exit Sub
    Else
        Workbooks.Open FName
    End If
 
Upvote 0
I have tested with this:

Code: 
Sub Test()
    Dim FName As Variant
    FName = Application.GetOpenFilename(FileFilter:="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
    SG_MoveColumns ("Starts")
End Sub

Sub SG_MoveColumns(sSheetname As String)
    Dim src As Worksheet     '
    Set src = Worksheets(sSheetname)
End Sub

and it works provided that the workbook that was opened contains a worksheet named Starts.
 
Upvote 0
You must log in or register to reply here.

Similar threads

willow1985
  • Solved
VBA Code help - How do I change source and destination from a single value to a list?
Replies
6
Views
125
willow1985
willow1985
Guna13
  • Question Question
How to Efficient way for create Multiple Workbooks
Replies
1
Views
420
Guna13
Guna13
KlausW
  • Solved
copy data from several closed workbooks to one workbook.
Replies
5
Views
1K
KlausW
KlausW
S
  • Question Question
Need code that adds multiple new rows to table to include a check box in column "L" for each new row
Replies
0
Views
554
sspatriots
S
W
  • Solved
Code doesn't work when switching tabs
Replies
6
Views
572
WilliamA
W

Forum statistics

Threads
1,225,739
Messages
6,186,738
Members
453,369
Latest member
juliewar

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top