VBA: Open workbook, save as....

T

Tommyk

New Member
Joined
Mar 2, 2011
Messages
8
Hi, everyone.

I have some code which currently runs from workbook1, which opens workbook2 (if not already open) and then performs some simple copy and paste functions.

I have been trying to update this code (with no success) to look for workbook2 and if not found to create workbook2 from workbook3 (located in S:\) and then Save as "workbook1stantec.xlsx" in same location as workbook1.

If anyone knows the code for this function it would be a great help. Bellow is the code i have.

Thanks in advance.

Tommy

Code: 
Option Explicit
Sub test1()
    Dim wbTarget As Workbook
    Dim wbSource As Workbook
    Dim wsTarget As Worksheet
    Dim wsSource As Worksheet
    Dim strName As String
    Dim MyPath As String
    Dim sRng As Range
    Dim sCell As Range
    Dim LR As Long
    Dim i As Long

    Application.ScreenUpdating = False
    MyPath = ActiveWorkbook.Path

    Set wbSource = ActiveWorkbook
    Set wsSource = wbSource.Sheets("MTS")

    strName = "*Stantec.xlsx"
    If Not IsWbOpen(strName) Then
        Set wbTarget = Application.Workbooks.Open(MyPath & "\" & strName)
    Else
        Set wbSource = Workbooks(strName)
    End If

    Set wsTarget = wbTarget.Sheets("Enter Materials Info")

    With wsSource
        LR = .Range("C" & .Rows.Count).End(xlUp).Row
        Set sRng = wsSource.Range("C2:C" & LR)
        i = 0

        For Each sCell In sRng
        wsTarget.Range("C2").Offset(1, i).Value = sCell.Value
            wsTarget.Range("C2").Offset(1, i).Value = sCell.Offset(0, 1).Value
            wsTarget.Range("C2").Offset(3, i).Value = sCell.Offset(0, 0).Value
            wsTarget.Range("C2").Offset(2, i).Value = sCell.Offset(0, 4).Value
            wsTarget.Range("C2").Offset(32, i).Value = sCell.Offset(0, 6).Value
            wsTarget.Range("C2").Offset(33, i).Value = sCell.Offset(0, 7).Value
            wsTarget.Range("C2").Offset(34, i).Value = sCell.Offset(0, 8).Value
            wsTarget.Range("C2").Offset(35, i).Value = sCell.Offset(0, 9).Value
            wsTarget.Range("C2").Offset(51, i).Value = sCell.Offset(0, 12).Value
            wsTarget.Range("C2").Offset(52, i).Value = sCell.Offset(0, 13).Value
            wsTarget.Range("C2").Offset(53, i).Value = sCell.Offset(0, 16).Value
            wsTarget.Range("C2").Offset(54, i).Value = sCell.Offset(0, 17).Value
            wsTarget.Range("C2").Offset(55, i).Value = sCell.Offset(0, 18).Value
            wsTarget.Range("C2").Offset(75, i).Value = sCell.Offset(0, 23).Value
            wsTarget.Range("C2").Offset(76, i).Value = sCell.Offset(0, 24).Value
            wsTarget.Range("C2").Offset(77, i).Value = sCell.Offset(0, 20).Value
            wsTarget.Range("C2").Offset(78, i).Value = sCell.Offset(0, 25).Value
            wsTarget.Range("C2").Offset(106, i).Value = sCell.Offset(0, 32).Value
            wsTarget.Range("C2").Offset(109, i).Value = sCell.Offset(0, 29).Value
            i = i + 1
        Next sCell
    End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Function IsWbOpen(wbName As String) As Boolean
    Dim i As Long
    For i = Workbooks.Count To 1 Step -1
        If Workbooks(i).Name = wbName Then Exit For
    Next
    If i <> 0 Then IsWbOpen = True
End Function
Code provided by Jaslake
 

Excel Facts

Back into an answer in Excel
Use Data, What-If Analysis, Goal Seek to find the correct input cell value to reach a desired result
Sort by date Sort by votes
I have been working with this, but it keeps coming up with compile error when i put it into the code above??

Code: 
' If a StantecMTS file exists for User Chosen Floor, open it
    If FileExists(sPath & "\" & (Left(strName, 3) & "StantecMTS.xlsx")) Then
        Set oWbk = Workbooks.Open(sPath & "\" & (Left(strName, 3) & "StantecMTS.xlsx"))    'opens the file
        sPath = ""

        ' if it does not exist, create it for the User Chosen Floor
    Else
        sPath = "\\pfdserver\shared\HKM\BCH LEED"    'You will need to change this Drive Letter
        ChDir sPath
        sFil = Dir("*.xlsx")    'change or add formats

        Do
            If sFil = "Stantec MTS (Template).xlsx" Then
                Set oWbk = Workbooks.Open(sPath & "\" & sFil)    'opens the file
                ActiveWorkbook.SaveAs fileName:=SrcPath & "\" & Left(strName, 3) & "StantecMTS.xlsx", FileFormat _
                        :=51
            End If
        Loop While sFil <> "Stantec MTS (Template).xlsx"   ' End of LOOP
    End If
 
Upvote 0
Hi Tommyk,
Does it stop on sPath? I copied your code & that's were it throws a compile error for me.
sPath hasn't been given a value. Perhaps you meant it to have the value of MyPath?
You also may need to have the FileExists function somehere in you module:
Function FileExists(FullFileName As String) As Boolean
' returns TRUE if the file exists
FileExists = Len(Dir(FullFileName)) > 0
End Function

HTH
 
Upvote 0
Hi Alan,

It does stop at sPath, I will change to MyPath and see what happens and then will try the FileExists.

Thanks for the reply
 
Upvote 0
Ok, I have added a value for sPath, and also added the Function FileExists at the end. It runs through but for some reason stops at

Code: 
Set wsSource = wbSource.Sheets("MTS")
Here is complete CODE

Code: 
Option Explicit
Sub test1()
    Dim wbTarget As Workbook
    Dim wbSource As Workbook
    Dim wsTarget As Worksheet
    Dim wsSource As Worksheet
    Dim strName As String
    Dim SrcPath As String
    Dim MyPath As String
    Dim sRng As Range
    Dim sCell As Range
    Dim LR As Long
    Dim i As Long
    Dim oWbk As Workbook
    Dim sFil As String
    Dim sPath As String

    Application.ScreenUpdating = False
    MyPath = ActiveWorkbook.Path

    Set wbSource = ActiveWorkbook
    Set wsSource = wbSource.Sheets("MTS")
    
    sPath = ActiveWorkbook.Path
    ChDir sPath
 
' If a Stantec file exists, open it
    If FileExists(sPath & "\" & (Left(strName, 3) & "Stantec.xlsx")) Then
        Set oWbk = Workbooks.Open(sPath & "\" & (Left(strName, 3) & "Stantec.xlsx"))    'opens the file
        sPath = ""

        ' if it does not exist, create it for the User Chosen Floor
    Else
        sPath = "S:\HKM\BCH LEED"    'You will need to change this Drive Letter
        ChDir sPath
        sFil = Dir("*.xlsx")    'change or add formats

        Do
            If sFil = "Stantec MTS (Template).xlsx" Then
                Set oWbk = Workbooks.Open(sPath & "\" & sFil)    'opens the file
                ActiveWorkbook.SaveAs Filename:=SrcPath & "\" & Left(strName, 3) & "StantecMTS.xlsx", FileFormat _
                        :=51
            End If
        Loop While sFil <> "Stantec MTS (Template).xlsx"   ' End of LOOP
    End If
    
    Set wbTarget = ActiveWorkbook
    Set wsTarget = wbTarget.Sheets("Enter Materials Info")

    With wsSource
        LR = .Range("C" & .Rows.Count).End(xlUp).Row
        Set sRng = wsSource.Range("C2:C" & LR)
        i = 0

        For Each sCell In sRng
        wsTarget.Range("C2").Offset(1, i).Value = sCell.Value
            wsTarget.Range("C2").Offset(1, i).Value = sCell.Offset(0, 1).Value
            wsTarget.Range("C2").Offset(3, i).Value = sCell.Offset(0, 0).Value
            wsTarget.Range("C2").Offset(2, i).Value = sCell.Offset(0, 4).Value
            wsTarget.Range("C2").Offset(32, i).Value = sCell.Offset(0, 6).Value
            wsTarget.Range("C2").Offset(33, i).Value = sCell.Offset(0, 7).Value
            wsTarget.Range("C2").Offset(34, i).Value = sCell.Offset(0, 8).Value
            wsTarget.Range("C2").Offset(35, i).Value = sCell.Offset(0, 9).Value
            wsTarget.Range("C2").Offset(51, i).Value = sCell.Offset(0, 12).Value
            wsTarget.Range("C2").Offset(52, i).Value = sCell.Offset(0, 13).Value
            wsTarget.Range("C2").Offset(53, i).Value = sCell.Offset(0, 16).Value
            wsTarget.Range("C2").Offset(54, i).Value = sCell.Offset(0, 17).Value
            wsTarget.Range("C2").Offset(55, i).Value = sCell.Offset(0, 18).Value
            wsTarget.Range("C2").Offset(75, i).Value = sCell.Offset(0, 23).Value
            wsTarget.Range("C2").Offset(76, i).Value = sCell.Offset(0, 24).Value
            wsTarget.Range("C2").Offset(77, i).Value = sCell.Offset(0, 20).Value
            wsTarget.Range("C2").Offset(78, i).Value = sCell.Offset(0, 25).Value
            wsTarget.Range("C2").Offset(106, i).Value = sCell.Offset(0, 32).Value
            wsTarget.Range("C2").Offset(109, i).Value = sCell.Offset(0, 29).Value
            i = i + 1
        Next sCell
    End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Function IsWbOpen(wbName As String) As Boolean
    Dim i As Long
    For i = Workbooks.Count To 1 Step -1
        If Workbooks(i).Name = wbName Then Exit For
    Next
    If i <> 0 Then IsWbOpen = True
End Function
Function FileExists(FullFileName As String) As Boolean
' returns TRUE if the file exists
    FileExists = Len(Dir(FullFileName)) > 0
End Function
 
Upvote 0
Quick update

Im getting a Subscript out of range error on


Set wsSource = wbSource.Sheets("MTS")</pre>
Thanks for any help
 
Upvote 0
Do you have a sheet called MTS in the source workbook?
It appears the code is looking for that as the source and the error you are receiving is consistent with Excel not finding MTS
 
Upvote 0
I had a slight error in my spelling.

It runs now, but i think my machine struggles with the code as 1 in 3 times it crashes Excel (Not Responding)??

We have very slow machines here.

Thanks for the help.
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question Question
VBA Copy/Paste New Data Only
Replies
0
Views
438
ah2024_2024
A
R
  • Solved
Loop through Rows
Replies
4
Views
376
rollingzep
R
U
  • Question Question
Information overwriting when transferring
Replies
7
Views
487
UTB
U
F
  • Question Question
Macro that copies and pastes from each file into formatted master sheet with merged cells
Replies
1
Views
949
OaklandJim
O
N
  • Solved
Looking to get Name value offset to set dynamic sheet names
Replies
1
Views
462
nutbolt
N

Forum statistics

Threads
1,224,568
Messages
6,179,595
Members
452,927
Latest member
whitfieldcraig

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