VBA: Replace Defined Range from Another Workbook with Dynamic

[donatepresent]

Hi Experts,

I'm trying to make my code more dynamic rather than static so, I want to replace the following code:

    FileToOpen = Application.GetOpenFilename
    Set OpenBook = Application.Workbooks.Open(FileToOpen)
        OpenBook.Sheets("Programs").Range("BD3:BD41").Copy .Range("BE3")
    OpenBook.Close False

Instead of defined 'Range("BD3:BD41")' in above OpenBook range, I want it to do the below code or better yet find the first column in the Pivot Table [in OpenBook.Sheets("Programs")] that contains "Grand Total" (would be in Row 4) and copy from that column from 'Row 3 to Row 41' and paste to ActiveWorkbook.Sheets("Sheet2") in BE3 or better yet the column right of the last column <-- see full code below:

    Range("D4").Select
    Selection.End(xlToRight).Select
    Selection.End(xlToRight).Select
    Selection.End(xlToRight).Select
    Selection.End(xlToRight).Select
    Selection.End(xlToRight).Select
    ActiveCell.Offset(1, 1).Activate
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Range ("BE3")

Full code:

    Application.AskToUpdateLinks = False
   
    Dim FileToOpen As Variant
    Dim OpenBook As Workbook
   
    With ActiveWorkbook.Sheets("Sheet2")
    MsgBox "Please select last month FS file"
   
    FileToOpen = Application.GetOpenFilename
    Set OpenBook = Application.Workbooks.Open(FileToOpen)
        OpenBook.Sheets("Programs").Range("BD3:BD41").Copy .Range("BE3")
    OpenBook.Close False
   
      With .Range("D44", Cells(43, Columns.Count).End(xlToLeft).Offset(1))
         .FormulaR1C1 = _
           "=IFERROR(HLOOKUP(R[-38]C,'[FileToOpen]Programs'!R6C4:R41C55,36,FALSE),"""")"
         .Style = "Comma"
      End With
    End With
   
    Range("D43").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Range("D44").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
   
    Application.AskToUpdateLinks = True

Thanks ,
Ken

 

[JLGWhiz]

The code you posted does not make sense because after you copy and paste the column of data, the workbook is closed without saving. The code below will find "Grand Total" column and copy that column (rows 3:41) to the next available column of the same sheet, according to the sample code. But it will save the workbook upon closing.

Dim Col As Long
 FileToOpen = Application.GetOpenFilename
 Set OpenBook = Application.Workbooks.Open(FileToOpen)
     With OpenBook.Sheets("Programs")
         Col = .Rows(4).Find("Grand Total", , xlValues, xlWhole).Row
         Cells(3, Col).Resize(39).Copy .Cells(3, Columns.Count).End(xlToLeft).Offset(, 1)
     End With
 OpenBook.Close True

 

[donatepresent]

The code you posted does not make sense because after you copy and paste the column of data, the workbook is closed without saving. The code below will find "Grand Total" column and copy that column (rows 3:41) to the next available column of the same sheet, according to the sample code. But it will save the workbook upon closing.

Dim Col As Long
FileToOpen = Application.GetOpenFilename
Set OpenBook = Application.Workbooks.Open(FileToOpen)
     With OpenBook.Sheets("Programs")
         Col = .Rows(4).Find("Grand Total", , xlValues, xlWhole).Row
         Cells(3, Col).Resize(39).Copy .Cells(3, Columns.Count).End(xlToLeft).Offset(, 1)
     End With
OpenBook.Close True

Hi JLGWhiz,

There are two workbooks. I need this code to paste it to this workbook "ActiveWorkbook.Sheets("Sheet2")" after copying from OpenBook, that is why it is not saved because I am not saving the OpenBook workbook. Look at full code.

Thanks,
Ken

 

[JLGWhiz]

Hi JLGWhiz,

There are two workbooks. I need this code to paste it to this workbook "ActiveWorkbook.Sheets("Sheet2")" after copying from OpenBook, that is why it is not saved because I am not saving the OpenBook workbook. Look at full code.

Thanks,
Ken

Try this.

Dim FileToOpen As Variant
    Dim OpenBook As Workbook
    Dim wb As Workbook, col As Long
    Set wb = ActiveWorkbook    
    MsgBox "Please select last month FS file"   
    FileToOpen = Application.GetOpenFilename
    Set OpenBook = Application.Workbooks.Open(FileToOpen)        
        With OpenBook.Sheets("Programs")
             Col = .Rows(4).Find("Grand Total", , xlValues, xlWhole).Row
             .Cells(3, Col).Resize(39).Copy wb.Cells(3, Columns.Count).End(xlToLeft).Offset(, 1)
        End With
   OpenBook.Close False

 

[donatepresent]

Try this.

Dim FileToOpen As Variant
    Dim OpenBook As Workbook
    Dim wb As Workbook, col As Long
    Set wb = ActiveWorkbook  
    MsgBox "Please select last month FS file" 
    FileToOpen = Application.GetOpenFilename
    Set OpenBook = Application.Workbooks.Open(FileToOpen)      
        With OpenBook.Sheets("Programs")
             Col = .Rows(4).Find("Grand Total", , xlValues, xlWhole).Row
             .Cells(3, Col).Resize(39).Copy wb.Cells(3, Columns.Count).End(xlToLeft).Offset(, 1)
        End With
   OpenBook.Close False

Hi JLGWhiz,

I don't see the pasted data in ActiveWorkbook.Sheets("Sheet2") and it also makes this line of code not work (the With.Range):

    With .Range("D44", Cells(43, Columns.Count).End(xlToLeft).Offset(1))
         .FormulaR1C1 = _
           "=IFERROR(HLOOKUP(R[-38]C,'[FileToOpen]Programs'!R6C4:R41C55,36,FALSE),"""")"
         .Style = "Comma"
      End With
    End With

 

[JLGWhiz]

That is because I left the sheet reference out. Replace this line:

.Cells(3, Col).Resize(39).Copy wb.Cells(3, Columns.Count).End(xlToLeft).Offset(, 1)

With this line

.Cells(3, Col).Resize(39).Copy wb.Sheets(2).Cells(3, Columns.Count).End(xlToLeft).Offset(, 1)

 

[donatepresent]

That is because I left the sheet reference out. Replace this line:

.Cells(3, Col).Resize(39).Copy wb.Cells(3, Columns.Count).End(xlToLeft).Offset(, 1)

With this line

.Cells(3, Col).Resize(39).Copy wb.Sheets(2).Cells(3, Columns.Count).End(xlToLeft).Offset(, 1)

Hi JLGWhiz,

I tried a number of combinations with your suggested change and no luck. I still don't see the data getting pasted there and its still interfering with the other code.

 

[JLGWhiz]

This is how the section of code you posted should now look.

 Application.AskToUpdateLinks = False   
    Dim FileToOpen As Variant
    Dim OpenBook As Workbook
    Dim wb As Workbook, col As Long
    Set wb = ActiveWorkbook
    With wb.Sheets("Sheet2")
    MsgBox "Please select last month FS file"   
    FileToOpen = Application.GetOpenFilename
    Set OpenBook = Application.Workbooks.Open(FileToOpen)
        With OpenBook.Sheets("Programs")
             col = .Rows(4).Find("Grand Total", , xlValues, xlWhole).Column
             .Cells(3, col).Resize(39).Copy wb.Sheets(2).Cells(3, Columns.Count).End(xlToLeft).Offset(, 1)
        End With
    OpenBook.Close False   
      With .Range("D44", Cells(43, Columns.Count).End(xlToLeft).Offset(1))
         .FormulaR1C1 = _
           "=IFERROR(HLOOKUP(R[-38]C,'[FileToOpen]Programs'!R6C4:R41C55,36,FALSE),"""")"
         .Style = "Comma"
      End With
    End With   
    Range("D43").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Range("D44").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False   
    Application.AskToUpdateLinks = True

 

[donatepresent]

This is how the section of code you posted should now look.

 Application.AskToUpdateLinks = False
    Dim FileToOpen As Variant
    Dim OpenBook As Workbook
    Dim wb As Workbook, col As Long
    Set wb = ActiveWorkbook
    With wb.Sheets("Sheet2")
    MsgBox "Please select last month FS file"
    FileToOpen = Application.GetOpenFilename
    Set OpenBook = Application.Workbooks.Open(FileToOpen)
        With OpenBook.Sheets("Programs")
             col = .Rows(4).Find("Grand Total", , xlValues, xlWhole).Column
             .Cells(3, col).Resize(39).Copy wb.Sheets(2).Cells(3, Columns.Count).End(xlToLeft).Offset(, 1)
        End With
    OpenBook.Close False
      With .Range("D44", Cells(43, Columns.Count).End(xlToLeft).Offset(1))
         .FormulaR1C1 = _
           "=IFERROR(HLOOKUP(R[-38]C,'[FileToOpen]Programs'!R6C4:R41C55,36,FALSE),"""")"
         .Style = "Comma"
      End With
    End With
    Range("D43").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Range("D44").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.AskToUpdateLinks = True

Copy and pasted exact and no luck. The macro runs without errors but doesn't do anything. It just did the formatting section and HLOOKUP (sometimes) and nothing for the find Grand Total in 4th row, offset to right 1 and copy and paste from row 3 to 41.

 

[JLGWhiz]

My test set up was running the code from the ActiveWorkbook, Opened second workbook with sheet named "Programs" and "Grand Total" in row 4 with arbirrary column.
The code ran without error and found "Grand Total", copied the rows 3:41 of that column to the next available column in Sheet 2 of the host workbook. So the code is doing what it was written to do. If you open the vb editor and use the F8 key to step through the code, with the editor screen diminished and positioned so you can see your worksheet, maybe you can spot where the problem is and we can then fix it. Right now, I have no clue.