Excel/VBA Code

Advertisement


Question
QUESTION: Hi Tom

First the previous fixed worked great, all good..!!!!

i have the code below which works fine, i am wondering if its possible and if so what would the change be if i wanted the path for the target workbook to be a variable and have it reference a cell, so if they do change the name of the file or the path they can just type it in that specific cell and when macro is run it finds it from that cell reference without having me go back into the vba everytime to change the path....

Thanks Tom

Sub Savecliententry2()

Application.ScreenUpdating = False


    Dim Sh1 As Worksheet, Sh2 As Worksheet
    Dim bk1 As Workbook
    Dim bk2 As Workbook
    Dim r1 As Range, r2 As Range
    Dim NextRow As Long
    Cancel = True
    
    ' source workbook
    Set bk1 = ThisWorkbook
    bk1.Activate
    Set Sh1 = bk1.Worksheets("Database22")
    Set r1 = Sh1.Range("B13:AK13")
    
 
     ' Target workbook
    Application.Workbooks.Open ("C:UsersAnthonyDesktopES900GSsample.xlsx") 'change the path and file name where you want to send data
    Set bk2 = Workbooks("sample.xlsx") ' change name for yr needs "Master"
    bk2.Activate
    
    Set Sh2 = bk2.Worksheets("Database")
    Set r2 = Sh2.Range("B4:AK4")
    Sh2.Unprotect Password:=Sheet1.Range("W1")
    NextRow = Sh2.Range("b65536").End(xlUp).Row + 1
    If NextRow < 3 Then NextRow = 3
    
    r1.Copy
    Sh2.Cells(NextRow, "b").PasteSpecial xlValues
    'r2.PasteSpecial xlValues  <== this line turned off; now a comment
    
    Sh2.Protect Password:=Sheet1.Range("W1")
    
    
   Application.Workbooks("sample.xlsx").Save
   Application.Workbooks("sample.xlsx").Close
   
Application.ScreenUpdating = True
      
    
End Sub

ANSWER: Anthony,

change these lines:

    Set r1 = Sh1.Range("B13:AK13")

   Application.Workbooks.Open ("C:UsersAnthonyDesktopES900GSsample.xlsx")
    Set bk2 = Workbooks("sample.xlsx") ' change name for yr needs "Master"
    bk2.Activate


to
    Set r1 = Sh1.Range("B13:AK13")
    Dim r3 as Range, sName as String
    Set r3 = Sh1.Range("A1")  ' change to refer to the cell
         ' with the path and name of the workbook
    sName = c:\Users\Anthony\Desktopy\ES900GS\sample.xlsx"
    if Len(trim(r3.value)) <> 0 then
       sName = r3.Value
    end if
   Application.Workbooks.Open sName
   ' when the workbook is opened, it will be the active workbook
   set bk2 = ActiveWorkbook

----------
Change

  Application.Workbooks("sample.xlsx").Save
  Application.Workbooks("sample.xlsx").Close

to
  
  Bk2.Close SaveChanges:=True

--
Regards,
Tom Ogilvy



---------- FOLLOW-UP ----------

QUESTION: Ok tried that and it comes up with yellow line error at the follow line

Application.Workbooks.Open sName

and i have typed into cell H28 on Sh17 the following:

("C:\Users\Anthony\Desktop\ES900GS\Sample.xlsm")

and the only file in that folder is sample.xlsm


here is the code i copied and modified

Application.ScreenUpdating = False


    Dim Sh1 As Worksheet, Sh2 As Worksheet
    Dim bk1 As Workbook
    Dim bk2 As Workbook
    Dim r1 As Range, r2 As Range
    Dim NextRow As Long
    Cancel = True
    
       ' source workbook
    Set bk1 = ThisWorkbook
    bk1.Activate
    Set Sh1 = bk1.Worksheets("TransferService")
    Set r1 = Sh1.Range("B4:AK4")
    
 
       Dim r3 As Range, sName As String
       Set r3 = Sh17.Range("H28")  ' change to refer to the cell
       ' with the path and name of the workbook
       ' Target workbook

       
       sName = "C:\Users\Anthony\Desktop\ES900GS\ES 725GSW.xlsm"
       If Len(Trim(r3.Value)) <> 0 Then
       sName = r3.Value
       End If


   Application.Workbooks.Open sName
   ' when the workbook is opened, it will be the active workbook
   Set bk2 = ActiveWorkbook
    
    
       Set Sh2 = bk2.Worksheets("Database")
       Set r2 = Sh2.Range("B4:AK4")
       Sh2.unprotect Password:=Sheet1.Range("W1")
       NextRow = Sh2.Range("b65536").End(xlUp).Row + 1
       If NextRow < 3 Then NextRow = 3
    
       r1.Copy
       Sh2.Cells(NextRow, "b").PasteSpecial xlValues
       'r2.PasteSpecial xlValues  <== this line turned off; now a comment
    
       Sh2.Protect Password:=Sheet1.Range("W1")
    
       bk2.Close SaveChanges:=True
   
Application.ScreenUpdating = True

ANSWER:
I don't see where sh17 is set as a reference to a sheet - if it is higher in the code then OK


>and i have typed into cell H28 on Sh17 the following:

("C:\Users\Anthony\Desktop\ES900GS\Sample.xlsm")

You should have

C:\Users\Anthony\Desktop\ES900GS\Sample.xlsm

in cell H28.  No double quotes; no parentheses

--
Regards,
Tom Ogilvy


---------- FOLLOW-UP ----------

QUESTION: ok lord knows its probably something small....

i have in cell h28 on sheet 17 "view" the following

C:\Users\Anthony\Desktop\ES900GS\Sample.xlsm

and the code below ...the source sheets are

Transferservice = sheet219
view = sheet17


and below is the code the error shows up on line as follows:

Application.Workbooks.Open sName

ideas?

Tony
===========

Application.ScreenUpdating = False


    Dim Sh1 As Worksheet, Sh2 As Worksheet, Sh3 As Worksheet
    Dim bk1 As Workbook
    Dim bk2 As Workbook
    Dim r1 As Range, r2 As Range
    Dim NextRow As Long
    Cancel = True
    
       ' source workbook
    Set bk1 = ThisWorkbook
    bk1.Activate
    Set Sh1 = bk1.Worksheets("TransferService")
    Set r1 = Sh1.Range("B4:AK4")
    
 
       Dim r3 As Range, sName As String
       Set Sh3 = bk1.Worksheets("view")
       Set r3 = Sh3.Range("H28")  ' change to refer to the cell
       ' with the path and name of the workbook
       ' Target workbook

       
       sName = "C:\Users\Anthony\Desktop\ES900GS\ES 725GSW.xlsm"
       If Len(Trim(r3.Value)) <> 0 Then
       sName = r3.Value
       End If


   Application.Workbooks.Open sName
   ' when the workbook is opened, it will be the active workbook
   Set bk2 = ActiveWorkbook
    
    
       Set Sh2 = bk2.Worksheets("Database")
       Set r2 = Sh2.Range("B4:AK4")
       Sh2.unprotect Password:=Sheet1.Range("W1")
       NextRow = Sh2.Range("b65536").End(xlUp).Row + 1
       If NextRow < 3 Then NextRow = 3
    
       r1.Copy
       Sh2.Cells(NextRow, "b").PasteSpecial xlValues
       'r2.PasteSpecial xlValues  <== this line turned off; now a comment
    
       Sh2.Protect Password:=Sheet1.Range("W1")
    
       bk2.Close SaveChanges:=True
   
Application.ScreenUpdating = True

Answer
anthony,

Anthony,

Run a few tests:

Sub Test1

Application.Workbooks.Open "C:\Users\Anthony\Desktop\ES900GS\Sample.xlsm"

End Sub


If that works then

in Sheet View, cell H28 I have:  C:\Users\Anthony\Desktop\ES900GS\Sample.xlsm

Sub Test2
sName = thisworkbook.Worksheets("View").Range("H28").Value
Application.Workbooks.Open sName

End Sub


Both of these worked perfectly for me when I had valid fully qualified Sheetname that was used as the first argument of   Application.Workbooks.Open

--
Regards,
Tom Ogilvy  
About Excel
This topic answers questions related to Microsoft Excel spreadsheet (or workbook) stand-alone or Mircrosoft Office Excel including Excel 2003, Excel 2007, Office 2000, and Office XP. You can get Excel help on Excel formulas(or functions), Excell macros, charting in Excel, advanced features, and the general use of Excel. This does not provide a general Excel tutorial nor the basics of using a spreadsheet. It provides specific answers to using Microsoft Excel only. If you do not see your Excel question answered in this area then please ask an Excel question here

Excel

All Answers


Answers by Expert:


Ask Experts

Volunteer


Tom Ogilvy

Expertise

Selected as an Excel MVP by Microsoft since 1999. Answering Excel questions in Allexperts since its inception in 2001. Able to answer questions on almost all aspects of Excel's internal capabilities. If seeking a VBA solution, please specify that in your question itself so I give you the answer you want. [Excel has weak protection - if you are distributing an application, I don't answer questions on how to protect your project from your users.]

Experience

Extensive experience.

Education/Credentials
Master of Science (MS) degree Operations Research (ORSA)

Awards and Honors
Microsoft MVP in Excel.

©2016 About.com. All rights reserved.