Copy from one workbook then paste into one other

[Nicolaf]

Hi,

I have done a macro to look for a cell in a worksheet and copy paste it into another worksheet of a different workbook.

Code below:

Private Sub CommandButton1_Click()
 
    IName = ThisWorkbook.Sheets("List").Range("B7").Value 'name with extension
    Set NewWkbk = Workbooks.Open(Filename:="P:\Lonib\" & IName)
    SName = ThisWorkbook.Sheets("List").Range("A7").Value 'sheet name
    NewWkbk.Sheets(SName).Select
    Windows(IName).Activate
    ActiveSheet.Calculate
    ActiveSheet.Range("M6").Select
    Selection.Copy
    Windows("Fixings.xls").Activate
    Sheets("List").Range("C7").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    Windows(IName).Activate
    ActiveWindow.Close
   
    IName = ThisWorkbook.Sheets("List").Range("B8").Value 'name with extension
    Set NewWkbk = Workbooks.Open(Filename:="P:\Lonib\" & IName)
    SName = ThisWorkbook.Sheets("List").Range("A8").Value 'sheet name
    NewWkbk.Sheets(SName).Select
    Windows(IName).Activate
    ActiveSheet.Calculate
    ActiveSheet.Range("M6").Select
    Selection.Copy
    Windows("Fixings.xls").Activate
    Sheets("List").Range("C8").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    Windows(IName).Activate
    ActiveWindow.Close
        
End Sub

So in file Fixings.xls in worksheet List we have the workbook to open (file name is in cell B7).
The worksheet to open is found in worksheet List in cell A7.
Once cell M6 has been copied then we move to next workbook found in cell B8 and next worksheet found in cell A8.

What I would like to do is a loop so that instead of repeating code for cell B7/A7, B8/A8 etc. it simply does this automatically for all data found in columns A and B of Fixings.xls until no more data is found and macro stops.

How can I do this?

Let me know if something not clear.

Thanks,
Nix

[SamT]

This code is just your recorded macro with all not needed stuff taken out to make it proper. Please study it carefully to understand what I did. You should do the same with any macro you record.

Private Sub Clean_CommandButton1_Click()
     
    'With B7 only
    Iname = ThisWorkbook.Sheets("List").Range("B7").Value 'name with extension
    Set NewWkBk = Workbooks.Open(Filename:="P:\Lonib\" & Iname)
    SName = ThisWorkbook.Sheets("List").Range("A7").Value 'sheet name
    
    Workbooks(Iname).Range("M6").Copy
    Workbooks("Fixings.xls").Sheets("List").Range("C7").PasteSpecial _
                                                        Paste:=xlPasteValues
    Workbooks(Iname).Close
     
End Sub

This code should solve your issue and run through the entire list of workbooks.

Private Sub New_CommandButton1_Click()
     
 Dim List As Worksheet
 Dim BkList As Range
 Dim ShtList As Range
 Dim FixList As Range
 Dim LastRow As Long
 Dim Iname As String
 Dim SName As String
 Dim NewWkBk As Workbook
 
 Dim cel As Long
 
 Set List = ThisWorkbook.Sheets("List")
 With List
    LastRow = .Range("B7").End(xlDown).Row
    Set BkList = .Range("B7:B" & LastRow)
    Set ShtList = .Range("A7:A" & LastRow)
  End With
 
 Set FixList = Workbooks("Fixings.xls").Sheets("List").Range("C7:C" & LastRow)
 
 For cel = 1 To BkList.Count
    
    Iname = BkList.Cells(cel).Value 'name with extension
    On Error GoTo celnext 'In case book is not exist
      Set NewWkBk = Workbooks.Open(Filename:="P:\Lonib\" & Iname)
    On Error GoTo 0 'stop error checking
    SName = ShtList.Cells(cel).Value 'sheet name
    
    Workbooks(Iname).Sheets(SName).Range("M6").Copy
    FixList.Cells(cel).PasteSpecial Paste:=xlPasteValues
    Workbooks(Iname).Close

celnext:
  Next cel
     
End Sub

Is "ThisWorkbook" the same book as "Fixings.xls"? If so, move the "Set FixList" line inside the "With List" section like this

 With List
    LastRow = .Range("B7").End(xlDown).Row
    Set BkList = .Range("B7:B" & LastRow)
    Set ShtList = .Range("A7:A" & LastRow)
    Set FixList = .Range("C7:C" & LastRow)
  End With

[Nicolaf]

Great that works really well!

One last feature please.

How would I amend your code to also refresh the worksheet which has been opened (so SName) and then close workbook (Iname) without saving?


I thought simply putting

ActiveSheet.Calculate

and

Workbooks(Iname).Close savechanges:=False

Would work but it does not.

Thanks,
Nix

[SamT]

Nothing on SName has changed, but if you want

        Workbooks(Iname).Sheets(SName).Range("M6").Copy
        FixList.Cells(cel).PasteSpecial Paste:=xlPasteValues
        
        Workbooks(Iname).Sheets(SName).Calculate
        Workbooks(Iname).Saved = True
        
        Workbooks(Iname).Close
         
celnext:
    Next cel

[Nicolaf]

Perfect thanks a lot!

Nix
Ps. In fact when you refresh worksheet SName if there is a formula then a value (in this case in M6) will change