VBA - Appending one list onto another on different sheet

[blonde]

Hi,

I have two lists on two separate sheets and I am trying to append one list (ws6) to the other (ws). It should copy the relevant ranges per row in sheet ws6 and paste them into the relevant columns in sheet ws. Then it should add in two values on two columns to each appended row in sheet ws. The code I have so far is not working. I think I need to put the 'i' in the coding lines which copy the data but I don't know how to get this right.

I'd be very grateful for any help on this. Here is my code:

Public Sub Append_unverified_Insurance_extract()

'This sub appends new unverified insurance data records from the 'Insurance Data - unverified' sheet into the 'Students Overseas' sheet


Dim ws As Worksheet
Dim ws6 As Worksheet
Dim Cell As Range

Set ws = ThisWorkbook.Sheets("Students Overseas")
Set ws6 = ThisWorkbook.Sheets("Insurance Data - unverified")

Finalrow = Sheets("Insurance Data - unverified").Range("A5000").End(xlUp).Row

Application.ScreenUpdating = False

With ws6

For i = 5 To Finalrow

    Cell.Offset(, 0).Resize(, 2).Copy ' Copy Faculty and Dept
                        ws.Range("A5000").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

    Cell.Offset(, 6).Resize(, 4).Copy ' Copy forename, surname, ID and SSN
                        ws.Range("A5000").End(xlUp).Offset(1, 3).PasteSpecial xlPasteValues

    Cell.Offset(, 2).Resize(, 4).Copy ' Copy Acad period, Aos code, Aos period and Course title
                        ws.Range("A5000").End(xlUp).Offset(1, 7).PasteSpecial xlPasteValues

    Cell.Offset(, 12).Copy ' Copy city
                        ws.Range("A5000").End(xlUp).Offset(1, 19).PasteSpecial xlPasteValues

    Cell.Offset(, 13).Copy ' Copy country
                        ws.Range("A5000").End(xlUp).Offset(1, 21).PasteSpecial xlPasteValues

    Cell.Offset(, 10).Resize(, 2).Copy  ' Copy travel start date and travel end date
                        ws.Range("A5000").End(xlUp).Offset(1, 34).PasteSpecial xlPasteValues

    Cell.Offset(, 15).Copy ' Copy trip approved by
                        ws.Range("A5000").End(xlUp).Offset(1, 46).PasteSpecial xlPasteValues

    Cell.Offset(, 17).Resize(, 2).Copy ' Copy purpose of trip & stage code
                        ws.Range("A5000").End(xlUp).Offset(1, 52).PasteSpecial xlPasteValues

    'And add in extra values to placement type and Record added by columns in 'Students Overseas' sheet:
    ws.Range("A5000").End(xlUp).Offset(1, 53).Value = "Insurance application"
    ws.Range("A5000").End(xlUp).Offset(1, 0).Value = "Insurance application - unverified"
    
    
    Next i
    
    End With
    
Application.ScreenUpdating = True

    
End Sub

 

[Fluff]

As you have given us no information at all, this is a guess

Sub blonde()
   Dim Ws As Worksheet, Ws6 As Worksheet
   Dim UsdRws As Long, NxtRw As Long, i As Long
   Dim Ary As Variant

   Set Ws = Sheets("Calc") 'ThisWorkbook.Sheets("Students Overseas")
   Set Ws6 = Sheets("Pcode") 'ThisWorkbook.Sheets("Insurance Data - unverified")

   UsdRws = Ws6.Range("A" & Rows.Count).End(xlUp).Row
   NxtRw = Ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
   Ary = Array(1, 0, 2, 7, 3, 4, 3, 7, 4, 13, 19, 1, 14, 21, 1, 11, 34, 2, 16, 46, 1, 18, 52, 2)

   Application.ScreenUpdating = False

   For i = 0 To UBound(Ary) Step 3
      Ws6.Cells(5, Ary(i)).Resize(UsdRws, Ary(i + 2)).Copy ' Copy Faculty and Dept
      Ws.Range("A" & NxtRw).Offset(, Ary(i + 1)).PasteSpecial xlPasteValues
   Next i
End Sub

 

[blonde]

Hi,

Thank you very much for your code. I've not used arrays before so I'm trying to understand how it works. I've managed to tweak the Ary = Array line to get the fields pasting into the correct columns and the code is working - data is being copied and pasted into the correct columns. However, there are a couple of things which need adjusting to get it fully working as needed:

1) When the rows are being copied from sheet Ws6 it is correctly copying from row 5 (in sheet Ws6, the column headers start on row 4 and the data on row 5.). However it is copying an extra 4 blank rows beyond the last row. These extra blank rows are being pasted into sheet ws creating four blank rows. How can I resolve this?

2) As per my original message, I also need to add in two fixed values into sheet ws. These are not within sheet Ws6:

value = "Insurance application - unverified" into each i, pasted into column A (,0)
value = "Insurance application" into each i, pasted into column BB (,52)

I hope this makes sense. I don't know how to add this into the coding. Please could you advise? I'd be very grateful for further help on this.

Here is my revised code:

Sub blonde()
   Dim Ws As Worksheet, Ws6 As Worksheet
   Dim UsdRws As Long, NxtRw As Long, i As Long
   Dim Ary As Variant

   Set Ws = Sheets("Students Overseas") 'ThisWorkbook.Sheets("Students Overseas")
   Set Ws6 = Sheets("Insurance Data - unverified") 'ThisWorkbook.Sheets("Insurance Data - unverified")

   UsdRws = Ws6.Range("A" & Rows.Count).End(xlUp).Row
   NxtRw = Ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
  'Ary = Array(1, 0, 2, 7, 3, 4, 3, 7, 4, 13, 19, 1, 14, 21, 1, 11, 34, 2, 16, 46, 1, 18, 52, 2) original
  
   Ary = Array(1, 1, 2, 7, 3, 3, 10, 10, 1, 3, 11, 4, 13, 19, 1, 14, 21, 1, 11, 34, 2, 16, 45, 1, 18, 51, 2)  'revised

   Application.ScreenUpdating = False

   For i = 0 To UBound(Ary) Step 3
      Ws6.Cells(5, Ary(i)).Resize(UsdRws, Ary(i + 2)).Copy
      Ws.Range("A" & NxtRw).Offset(, Ary(i + 1)).PasteSpecial xlPasteValues
   Next i
End Sub

 

[Fluff]

I didn't bother with the extra 2 values until the main part was sorted as I had no idea if everything was being copied from/to the correct location, try

Sub blonde()
   Dim Ws As Worksheet, Ws6 As Worksheet
   Dim UsdRws As Long, NxtRw As Long, i As Long
   Dim Ary As Variant

   Set Ws = Sheets("Students Overseas") 'ThisWorkbook.Sheets("Students Overseas")
   Set Ws6 = Sheets("Insurance Data - unverified") 'ThisWorkbook.Sheets("Insurance Data - unverified")

   UsdRws = Ws6.Range("A" & Rows.Count).End(xlUp).Row
   NxtRw = Ws.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
  'Ary = Array(1, 0, 2, 7, 3, 4, 3, 7, 4, 13, 19, 1, 14, 21, 1, 11, 34, 2, 16, 46, 1, 18, 52, 2) original
  
   Ary = Array(1, 1, 2, 7, 3, 3, 10, 10, 1, 3, 11, 4, 13, 19, 1, 14, 21, 1, 11, 34, 2, 16, 45, 1, 18, 51, 2)  'revised

   Application.ScreenUpdating = False

   For i = 0 To UBound(Ary) Step 3
      Ws6.Cells(5, Ary(i)).Resize(UsdRws - 4, Ary(i + 2)).Copy
      Ws.Range("A" & NxtRw).Offset(, Ary(i + 1)).PasteSpecial xlPasteValues
   Next i
   Ws.Range("A" & NxtRw).Offset(, 53).Resize(UsdRws - 4).Value = "Insurance application"
   Ws.Range("A" & NxtRw).Resize(UsdRws - 4).Value = "Insurance application - unverified"
End Sub

 

[blonde]

Thank you very much for your time today on this, it is now working successfully and is super quick!

 

[Fluff]

Glad to help & thanks for the feedback