Macro for Copying and pasting from one excel workbook into a series of other workbooks

[Smeddlesboy]

I am trying to create a Macro that pastes code from one workbook into a list of other workbooks. It's become a bit too complicated.

There is a folder containing many sheets, and rather than update them all individually, I want to be able to copy and paste a few new rows at the end of each one automatically.

In short, there is a Workbook called "Setup.xlsm" in which the cells to be copied and pasted are in range H10:M21 in the sheet "Pupils"
Also in the Workbook called "Setup.xlsm" is a list of all the names of the workbooks needing to be updated. These appear in column B in the sheet "Staff"

The copied cells need to be pasted into column A in each of these workbooks. The user defines which row to paste them in at. The row number is stored in cell M8 inthe "Pupils" sheet of the "setup.xlsm" sheet

The macro will be started from sheet "Setup.xlsm" sheet "Pupils". I need it to open each of the destination workbooks in turn, unprotect it, copy and paste the cells from the other workbook, reprotect the destination workbook, save it and close it.



Sorry the code below might be a bit of a mess, I have been experimenting so much with things I found on Google that I am all mixed up

Sub February()



    Dim i As Integer
    Dim j As Integer
    Dim Subfolder As String
    Dim SubfolderSubjNom As String
    Dim Targetfile As String
    Dim SubjFile As String
    Dim wbk As Workbook


    
    Sheets("Staff").Select
    Subfolder = ActiveSheet.Range("G1").Value
    SubfolderSubjNom = Subfolder & "SubjectNominations\"

    i = 1
    j = ActiveSheet.Range("M8").Value
    Do While Workbooks("Setup.xlsm").Sheets("Staff").Cells(i, 2).Value <> Empty
    SubjFile = SubfolderSubjNom & Workbooks("Setup.xlsm").Sheets("Staff").Cells(i, 2).Value & ".xlsm"
    Set wbk = Workbooks("Setup.xlsm")
    
    With wbk.Sheets("Pupils")
        Range("H10:M21").Copy
    End With

    Set wbk = Workbooks.Open(SubjFile)
    With wbk.Sheets("Nominations")
        ActiveSheet.Unprotect 
        Range("A" & j & ":F" & j + 11).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Range("A2").Select
        Workbook.Save
        Workbook.Close
    End With


    Loop
    
    
End Sub

[Smeddlesboy]

I've done a bit of reprogramming and have eliminated the need to enter the value in cell M8, which was stored as Integer j. I will just always paste the new values into row 1200 and then do an alphabetic sort to move them to the top.

Thought I'd type that in here in case it made suggesting a solution any easier!

[J450n]

Hi Smeddlesboy,

Does this code work as is? I'm not entirely sure what solution you're looking for, but assume the issue is finding the last empty row of the destination wbk/sheet then pasting and sorting???.

As is, you need to increment i by setting i = i+1 within the do loop before it loops

Regards

[Smeddlesboy]

Just ran it again, and the line it is getting stuck at is

        Range("A" & 1200 & ":F" & 1211).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False

Message is PasteSpecial method of Range class failed

[Smeddlesboy]

No, the code doesnt work as it is. It gets mixed up between which workbook and worksheet it is copying from and which one it is copying to - I can't get it to do the right thing in the right window

[J450n]

How about just pasting to range A1200 only???

[J450n]

Hi again, I've used your code but taken out the subjectnominations bit to test it on my machine. This code works for me - you'll need to put back the correct sheet names for your purposes.

Regards

Sub February()

    Dim Subfolder As String
    Dim SubfolderSubjNom As String
    Dim SubjFile As String
    Dim wbk As Workbook
    
    Dim rFiles As Range, rFree As Range
    Dim rData As Range
    Dim iLR As Integer
    Dim ws As Worksheet
    
    Set rFiles = ThisWorkbook.Sheets(1).Range("b1", Range("b1").End(xlDown))
    Set rData = ThisWorkbook.Sheets(1).Range("H10:M12")
    
    Sheets(1).Select
    Subfolder = ActiveSheet.Range("G1").Value
    
    For Each rFree In rFiles
        SubjFile = Subfolder & rFree.Value & ".xlsx"
        
        Set wbk = Workbooks.Open(SubjFile)
        Set ws = wbk.Sheets(1)
        With ws
            iLR = .Range("A" & .UsedRange.Rows.Count) + 1
            ActiveSheet.Unprotect
            rData.Copy Destination:=.Range("A" & iLR)
            .Range("A2").Select
            wbk.Save
            wbk.Close
        End With
    Next rFree

End Sub

[J450n]

Whoops, sent you the wrong code in last post as was still WIP!


Try this, have tested and is OK:

Sub February()

    Dim Subfolder As String
    Dim SubfolderSubjNom As String
    Dim SubjFile As String
    Dim wbk As Workbook
    
    Dim rFiles As Range, rFree As Range
    Dim rData As Range
    Dim iLR As Integer
    Dim ws As Worksheet
    
    Set rFiles = ThisWorkbook.Sheets(1).Range("b1", Range("b1").End(xlDown))
    Set rData = ThisWorkbook.Sheets(1).Range("H10:M12")
    
    Sheets(1).Select
    Subfolder = ActiveSheet.Range("G1").Value
    
    For Each rFree In rFiles
        SubjFile = Subfolder & rFree.Value & ".xlsx"
        
        Set wbk = Workbooks.Open(SubjFile)
        Set ws = wbk.Sheets(1)
        With ws
            .Unprotect
            iLR = .Range("A" & .UsedRange.Rows.Count).Row + 1
            rData.Copy Destination:=.Range("A" & iLR)
            .Range("A2").Select
        End With
        wbk.Save
        wbk.Close
    Next rFree

End Sub

[Smeddlesboy]

Thanks. Will give it a go this evening when I'm back from work and will let you know how it goes. thanks for your time.

[Smeddlesboy]

It's not liking the line

    Set rFiles = ThisWorkbook.Sheets("Staff").Range("B1", Range("B1").End(xlDown))

Any suggestions what I might have done wrong?

My full code is below. I've also added in a bit at the end that re-sorts the data.

Sub FebruaryAddNewPupils()


    Dim Subfolder As String
    Dim SubfolderSubjNom As String
    Dim SubjFile As String
    Dim wbk As Workbook
    
    Dim rFiles As Range, rFree As Range
    Dim rData As Range
    Dim iLR As Integer
    Dim ws As Worksheet

    Set rFiles = ThisWorkbook.Sheets("Staff").Range("B1", Range("B1").End(xlDown))
    Set rData = ThisWorkbook.Sheets("Pupils").Range("H10:M12")
    
    Sheets("Staff").Select
    Subfolder = ActiveSheet.Range("G1").Value
    SubfolderSubjNom = Subfolder & "SubjectNominations\"


    For Each rFree In rFiles
        SubjFile = SubfolderSubjNom & rFree.Value & ".xlsx"
        
        Set wbk = Workbooks.Open(SubjFile)
        Set ws = wbk.Sheets("Nominations")
        With ws
            .Unprotect 
            iLR = .Range("A" & .UsedRange.Rows.Count).Row + 1
            rData.Copy Destination:=.Range("A" & iLR)
            .Range("A2").Select
        End With

    
    
    
    'start re-sorting
    ActiveWorkbook.Worksheets("Nominations").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Nominations").AutoFilter.Sort.SortFields.Add Key:=Range _
        ("B5"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Nominations").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    

    ActiveWorkbook.Worksheets("Nominations").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Nominations").AutoFilter.Sort.SortFields.Add Key:=Range _
        ("C5"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Nominations").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
        ActiveWorkbook.Worksheets("Nominations").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Nominations").AutoFilter.Sort.SortFields.Add Key:=Range _
        ("D5"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Nominations").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    ActiveWorkbook.Worksheets("Nominations").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Nominations").AutoFilter.Sort.SortFields.Add Key:=Range _
        ("F5"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Nominations").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    'end re-sorting
    
    Range("A2").Select
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
            , AllowFiltering:=True


        wbk.Save
        wbk.Close
    Next rFree
    
    
End Sub

[J450n]

This should work, and as i said, i did test the code and all ok
Are you running the code from the Setup.xlsm workbook or a different file to test it??? Do the "Staff" & "Pupils" sheets exist??? Did you have some different workbooks open when you tested the code as if the "Activeworkbook" was not Setup.xlsm when you ran the code, it would fail as then the sheets wouldn't exist in that workbook. Please try again with only Setup.xlsm (or a copy) open and if any joy.
Failing that, I can only suggest removing the "Thisworkbook" part as shouldn't really need it if this is the only workbook open.

Just another comment regarding the sorting code, It will probably fail as intended because we dont select the workbook opened by the macro. Since we alreeady set it as "ws" suggest you change the code as follows:

With ws

    .AutoFilter.Sort.SortFields.Clear
    .AutoFilter.Sort.SortFields.Add Key:=Range _
    ("B5"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    xlSortTextAsNumbers
    .AutoFilter.Sort
    .Apply
    
    .AutoFilter.Sort.SortFields.Clear
    .AutoFilter.Sort.SortFields.Add Key:=Range _
    ("C5"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    xlSortTextAsNumbers
    .AutoFilter.Sort
    .Apply
    
    .AutoFilter.Sort.SortFields.Clear
    .AutoFilter.Sort.SortFields.Add Key:=Range _
    ("D5"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    xlSortTextAsNumbers
    .AutoFilter.Sort
    .Apply
    
    .AutoFilter.Sort.SortFields.Clear
    .AutoFilter.Sort.SortFields.Add Key:=Range _
    ("F5"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    xlSortTextAsNumbers
    .AutoFilter.Sort
    .Apply
    'end re-sorting
    
    Range("A2").Select
    .Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
            , AllowFiltering:=True

End With

Regards

J450n

[Smeddlesboy]

Thanks, will again look at it when back from work. Hopefully its just something as simple as me having had another workbook open at the same time.

though just gave it a quick test now, and when it tries to run

    .AutoFilter.Sort.SortFields.Clear
    .AutoFilter.Sort.SortFields.Add Key:=Range _
    ("B5"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    xlSortTextAsNumbers
    .AutoFilter.Sort
    .Apply

It brings up an error, and highlights the ".Sort" in the second last line and describes it as a "Compile Error: Invalid use of property"?

[Smeddlesboy]

Deleted - posted twice by mistake

[J450n]

Hi Smelldesboy,

i hope this will put it to bed for you. Let me know how this works out.

Sub FebruaryAddNewPupils_v3()


    Dim Subfolder As String
    Dim SubfolderSubjNom As String
    Dim SubjFile As String
    Dim wbk As Workbook
    
    Dim rFiles As Range, rFree As Range
    Dim rData As Range, rDest As Range 'new range variable added
    
    Dim iLR As Integer
    Dim ws As Worksheet

    Set rFiles = ThisWorkbook.Sheets("Staff").Range("B1", Range("B1").End(xlDown))
    Set rData = ThisWorkbook.Sheets("Pupils").Range("H10:M12")
    
    Sheets("Staff").Select
    Subfolder = ActiveSheet.Range("G1").Value
    SubfolderSubjNom = Subfolder & "SubjectNominations\"


    For Each rFree In rFiles
        SubjFile = SubfolderSubjNom & rFree.Value & ".xlsx"
        
        Set wbk = Workbooks.Open(SubjFile)
        Set ws = wbk.Sheets("Nominations")
        With ws
            .Unprotect
            iLR = .Range("A" & .UsedRange.Rows.Count).Row + 1
            rData.Copy Destination:=.Range("A" & iLR)
            
            'updated from here
'start re-sorting
            'reset last row in destination workbook
            iLR = .Range("A" & .UsedRange.Rows.Count).Row
            'define range to be sorted
            Set rDest = .Range("a5:g" & iLR) 'rData is 7 cols wide so also using 7 cols here
            'sort by columns B,C,D & F relative to top left cell of defined range
            rng.Sort key1:=rng(1, 2), key2:=rng(1, 3), key3:=rng(1, 4), key4:=rng(1, 6), Header:=xlNo
'end re-sorting
            
            .Range("A2").Select
            .Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
        End With
        wbk.Save
        wbk.Close
    Next rFree
    
End Sub

Regards

J450n

[Smeddlesboy]

Really sorry, and thanks still for all your effort.

However its not liking the

            iLR = .Range("A" & .UsedRange.Rows.Count).Row

It''s giving me "compile error, invalid or unqualified reference" - and is highlighting the .UsedRange part of the line as the ssource of the problem.

[J450n]

Ok, change it to this:

iLR = .Range("A" & .Rows.Count).End(xlUp).Row

[Smeddlesboy]

Ok were definitely getting somewhere now. Making good progress - I can make it work if I disablel one or two bits of the code temporarily, so must mean almost everything is sorted

It still isn't keen on the

Range("b1").End(xlDown)

bit - is there any other way of expressing this code that might improve things?

It also isn't liking

key1:=Rng(1, 2)

- it highlights the Rng and says "sub or function not defined". Again, anything I can tweak there?

All other lines are doing their job and throwing up no error messages

Thanks once more

[J450n]

for the 1st issue, try to grab the block with this.

range([b1],[b1].end(xldown))

IF this doesn't work, you can use the bounce up from the final row in column B as used elsewhere ie:

iLR = .Range("B" & .Rows.Count).End(xlUp).Row

then set the range as range("b1:b" & iLR)

as for the key issue, looks like the compiler is converting rng to Rng which doesnt exist hence the problem. I was using the Items method of the range object but maybe got a little lost in the syntax.maybe try rng.range("A1"), or rng.cells(1,4) etc and see how that works

I now see the error of my ways, there are 2 different ways of defining a block being confused here. We can either define a block by range("a1:a10") or else we have to do with 2 fully defined start/end ranges within another range statement with commar separator like range(range("a1"), range("a10")).
for the keys for the sort, just try retyping "Rng" back to "rng". I dont know why it would have got changed. If the compiler is for some reason changing it back to Rng, then best use Ctrl+f and find and replace all instances of Rng to something else. Good luck.

[Smeddlesboy]

Right I can get it to work by deleting a line or two of code and by changing rng to rDest. This is the code I currently have

Sub FebruaryAddNewPupils()


    Application.ScreenUpdating = True
    Application.DisplayAlerts = False

    Dim Subfolder As String
    Dim SubfolderSubjNom As String
    Dim SubjFile As String
    Dim wbk As Workbook
    
    Dim rFiles As Range, rFree As Range
    Dim rData As Range, rDest As Range
    Dim iLR As Integer
    Dim ws As Worksheet


    
    Sheets("Staff").Select
    Subfolder = ActiveSheet.Range("G1").Value
    SubfolderSubjNom = Subfolder & "SubjectNominations\"

    iLR = ThisWorkbook.Sheets.Range("B" & .Rows.Count).End(xlUp).Row
    Set rFiles = ThisWorkbook.Sheets("Staff").Range("B1:B" & iLR)
    Set rData = ThisWorkbook.Sheets("Pupils").Range("H10:M12")



    For Each rFree In rFiles
        SubjFile = SubfolderSubjNom & rFree.Value & ".xlsm"
        
        Set wbk = Workbooks.Open(SubjFile)
        Set ws = wbk.Sheets("Nominations")
        With ws
            .Unprotect
            iLR = .Range("A" & .UsedRange.Rows.Count).Row + 1
            rData.Copy Destination:=.Range("A" & iLR)

'start re-sorting
            'reset last row in destination workbook
            iLR = .Range("A" & .Rows.Count).End(xlUp).Row
            'define range to be sorted
            Set rDest = .Range("A5:W" & iLR)
            'sort by columns B,C,D & F relative to top left cell of defined range
            rDest.Sort key1:=rDest.Cells(1, 2), key2:=rDest.Cells(1, 3), key3:=rDest.Cells(1, 4), key4:=rDest(1, 6), Header:=xlYes
'end re-sorting
            
            .Range("A2").Select
            .Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
        End With

    
        wbk.Save
        wbk.Close
    Next rFree
    
    
End Sub

The bits it still isn't liking are

key1:=rDest.Cells(1, 2), key2:=rDest.Cells(1, 3), key3:=rDest.Cells(1, 4), key4:=rDest(1, 6),

It is OK if i delete the key2/key3/key4 bits; but doesn't like it when they are in there. I can't see why, as we have clearly defined rDest to have at least six columns

The other bit it still isn't liking is the very first instance of iLR i.e.

    iLR = ThisWorkbook.Sheets.Range("B" & .Rows.Count).End(xlUp).Row

where it highights .Rows and tells me its a compile error: invalid or unqualified reference

[Smeddlesboy]

Thanks, am getting somewhere - just need a little more work and I should be there. I am still unclear as to what 'rng' actually is though, as we havent defined 'rng' anywhere? I take it its actually rDest???

[J450n]

Ok, the line "iLR = ThisWorkbook.Sheets(xxxxxx).Range("B" & .Rows.Count).End(xlUp).Row" is missing the sheets reference betwen brackets where i've added the xxxxx's

as for the keys- ????? i've tested this a few times in a blank workbook, just add a say 5 row by 5 row block of random data in the 1st sheet, define it as a range and do the same sort, it all works fine. I'm lost why is not working for you - maybe need to send out a new post to see of someone can help explain.

Yes you were right rng should have been rDest - now you know what i called the range i was testing in a separate workbook!

I don't think i can add much more value to this for you, good luck getting it perfected.

Regards

J450n

[Smeddlesboy]

I think I finally have it - if I change it to be

iLR = ThisWorkbook.Sheets(xxxxxx).Range("B" & ThisWorkbook.Sheets(xxxxx).Rows.Count).End(xlUp).Row

then it works

I can also make the sorting work if i just choose key1 and leave keys 2-4 for now

Thanks a lot for your help. As you suggest, I will make another post to see if we can get the sorting issue dealt with: you helped me deal with the copying and pasting issue, and thank you very much for that!