none
Copy full Sheet from various XLS (plus column, row modification) RRS feed

  • Question

  • Dear All,

    I am dealing with a warehouse part number/comment tracing tool where I had a code before, but now my macro runs 40-50 mins, which is a little bit to much. (in the beginning i had no problem with this approach, because i had less part numbers, but as soon as the lines/part numbers grown now i am having this problem)

    To give a heads up: i need to combine 4 XLSs into one. Each XLS has the same tabs, but under on each tabs there are different lines. My main XLS has exactly the same tabs (tab names also equal) and what i do now is color the first row in the first tab, grab the first xls first tab data and insert with+for function, draw a line (for separator) grab the second excel first tab do the same, draw a line, 3rd excel first tab, do the same, draw a line, 4th excel 1st tab do the same. After this done I use the VLOOKUP functions to check the old comments and insert from the "last meeting" what we discussed.

    Code is here:

    Sub Parts() Dim wsInPutL As Worksheet Dim wsInPut1 As Worksheet Dim wsInPut2 As Worksheet Dim wsInPut3 As Worksheet Dim wsInPut4 As Worksheet Dim wsOutput As Worksheet Dim lRow As Long, NewRw As Long, i As Long, uccsosor As Long Set wsInPut1 = Workbooks(first).Sheets("Parts") Set wsInPut2 = Workbooks(second).Sheets("Parts") Set wsInPut3 = Workbooks(third).Sheets("Parts") Set wsInPut4 = Workbooks(fourth).Sheets("Parts") Set wsInPutL = Workbooks(last_meeting).Sheets("Parts") Set wsOutput = ThisWorkbook.Sheets("Parts") '~~> Start row in "Sheet2_Transposed data" 'coloring the row With wsOutput .Range("A" & Rows.Count).End(xlUp).Offset(1).EntireRow.Interior.Color = 42421 .Range("A" & Rows.Count).End(xlUp).Offset(1).Value = text_1 .Range("D" & Rows.Count).End(xlUp).Offset(1).Value = text_1 End With NewRw = 3

    'start the input With wsInPut1 '~~> Find Last Row lRow = .Range("A" & .Rows.Count).End(xlUp).Row '~~> Loop through the rows For i = 2 To lRow wsOutput.Range("A" & NewRw).Value = .Range("A" & i).Value wsOutput.Range("B" & NewRw).Value = .Range("B" & i).Value wsOutput.Range("C" & NewRw).Value = .Range("C" & i).Value wsOutput.Range("D" & NewRw).Value = .Range("A" & i).Value & .Range("B" & i).Value & .Range("C" & i).Value & "-" & Left(.Range("D" & i).Value, 1) wsOutput.Range("E" & NewRw).Value = Right(.Range("D" & i).Value, Len(.Range("D" & i).Value) - 3) wsOutput.Range("F" & NewRw).Value = Left(.Range("D" & i).Value, 1) wsOutput.Range("G" & NewRw).Value = .Range("E" & i).Value wsOutput.Range("H" & NewRw).Value = .Range("F" & i).Value wsOutput.Range("I" & NewRw).Value = .Range("G" & i).Value wsOutput.Range("J" & NewRw).Value = .Range("H" & i).Value wsOutput.Range("K" & NewRw).Value = .Range("I" & i).Value wsOutput.Range("L" & NewRw).Value = .Range("J" & i).Value wsOutput.Range("M" & NewRw).Value = .Range("K" & i).Value wsOutput.Range("N" & NewRw).Value = .Range("L" & i).Value wsOutput.Range("O" & NewRw).Value = .Range("M" & i).Value wsOutput.Range("P" & NewRw).Value = .Range("N" & i).Value wsOutput.Range("Q" & NewRw).Value = .Range("O" & i).Value NewRw = NewRw + 1 Next i End With 'coloring the next row With wsOutput .Range("A" & Rows.Count).End(xlUp).Offset(1).EntireRow.Interior.Color = 44407 .Range("A" & Rows.Count).End(xlUp).Offset(1).Value = text_2 .Range("D" & Rows.Count).End(xlUp).Offset(1).Value = text_2 End With 'second excel comming With wsInPut2 '~~> Find Last Row lRow = .Range("A" & .Rows.Count).End(xlUp).Row NewRw = NewRw + 1 '~~> Loop through the rows For i = 2 To lRow wsOutput.Range("A" & NewRw).Value = .Range("A" & i).Value wsOutput.Range("B" & NewRw).Value = .Range("B" & i).Value wsOutput.Range("C" & NewRw).Value = .Range("C" & i).Value wsOutput.Range("D" & NewRw).Value = .Range("A" & i).Value & .Range("B" & i).Value & .Range("C" & i).Value & "-" & Left(.Range("D" & i).Value, 1) wsOutput.Range("E" & NewRw).Value = Right(.Range("D" & i).Value, Len(.Range("D" & i).Value) - 3) wsOutput.Range("F" & NewRw).Value = Left(.Range("D" & i).Value, 1) wsOutput.Range("G" & NewRw).Value = .Range("E" & i).Value wsOutput.Range("H" & NewRw).Value = .Range("F" & i).Value wsOutput.Range("I" & NewRw).Value = .Range("G" & i).Value wsOutput.Range("J" & NewRw).Value = .Range("H" & i).Value wsOutput.Range("K" & NewRw).Value = .Range("I" & i).Value wsOutput.Range("L" & NewRw).Value = .Range("J" & i).Value wsOutput.Range("M" & NewRw).Value = .Range("K" & i).Value wsOutput.Range("N" & NewRw).Value = .Range("L" & i).Value wsOutput.Range("O" & NewRw).Value = .Range("M" & i).Value wsOutput.Range("P" & NewRw).Value = .Range("N" & i).Value wsOutput.Range("Q" & NewRw).Value = .Range("O" & i).Value wsOutput.Range("U" & NewRw).Value = "BIW" NewRw = NewRw + 1 Next i End With 'coloring the next row With wsOutput .Range("A" & Rows.Count).End(xlUp).Offset(1).EntireRow.Interior.Color = 49407 .Range("A" & Rows.Count).End(xlUp).Offset(1).Value = text_3 .Range("D" & Rows.Count).End(xlUp).Offset(1).Value = text_3 End With NewRw = wsOutput.Cells(wsOutput.Rows.Count, "A").End(xlUp).Offset(1).Row With wsInPut3 '~~> Find Last Row lRow = .Range("A" & .Rows.Count).End(xlUp).Row For i = 2 To lRow wsOutput.Range("A" & NewRw).Value = .Range("A" & i).Value wsOutput.Range("B" & NewRw).Value = .Range("B" & i).Value wsOutput.Range("C" & NewRw).Value = .Range("C" & i).Value wsOutput.Range("D" & NewRw).Value = .Range("A" & i).Value & .Range("B" & i).Value & .Range("C" & i).Value & "-" & Left(.Range("D" & i).Value, 1) wsOutput.Range("E" & NewRw).Value = Right(.Range("D" & i).Value, Len(.Range("D" & i).Value) - 3) wsOutput.Range("F" & NewRw).Value = Left(.Range("D" & i).Value, 1) wsOutput.Range("G" & NewRw).Value = .Range("E" & i).Value wsOutput.Range("H" & NewRw).Value = .Range("F" & i).Value wsOutput.Range("I" & NewRw).Value = .Range("G" & i).Value wsOutput.Range("J" & NewRw).Value = .Range("H" & i).Value wsOutput.Range("K" & NewRw).Value = .Range("I" & i).Value wsOutput.Range("L" & NewRw).Value = .Range("J" & i).Value wsOutput.Range("M" & NewRw).Value = .Range("K" & i).Value wsOutput.Range("N" & NewRw).Value = .Range("L" & i).Value wsOutput.Range("O" & NewRw).Value = .Range("M" & i).Value wsOutput.Range("P" & NewRw).Value = .Range("N" & i).Value wsOutput.Range("Q" & NewRw).Value = .Range("O" & i).Value wsOutput.Range("U" & NewRw).Value = "TC" NewRw = NewRw + 1 Next i End With 'coloring the next row With wsOutput .Range("A" & Rows.Count).End(xlUp).Offset(1).EntireRow.Interior.Color = 74407 .Range("A" & Rows.Count).End(xlUp).Offset(1).Value = text_4 .Range("D" & Rows.Count).End(xlUp).Offset(1).Value = text_4 End With NewRw = wsOutput.Cells(wsOutput.Rows.Count, "A").End(xlUp).Offset(1).Row With wsInPut4 '~~> Find Last Row lRow = .Range("A" & .Rows.Count).End(xlUp).Row '~~> Loop through the rows For i = 2 To lRow wsOutput.Range("A" & NewRw).Value = .Range("A" & i).Value wsOutput.Range("B" & NewRw).Value = .Range("B" & i).Value wsOutput.Range("C" & NewRw).Value = .Range("C" & i).Value wsOutput.Range("D" & NewRw).Value = .Range("A" & i).Value & .Range("B" & i).Value & .Range("C" & i).Value & "-" & Left(.Range("D" & i).Value, 1) wsOutput.Range("E" & NewRw).Value = Right(.Range("D" & i).Value, Len(.Range("D" & i).Value) - 3) wsOutput.Range("F" & NewRw).Value = Left(.Range("D" & i).Value, 1) wsOutput.Range("G" & NewRw).Value = .Range("E" & i).Value wsOutput.Range("H" & NewRw).Value = .Range("F" & i).Value wsOutput.Range("I" & NewRw).Value = .Range("G" & i).Value wsOutput.Range("J" & NewRw).Value = .Range("H" & i).Value wsOutput.Range("K" & NewRw).Value = .Range("I" & i).Value wsOutput.Range("L" & NewRw).Value = .Range("J" & i).Value wsOutput.Range("M" & NewRw).Value = .Range("K" & i).Value wsOutput.Range("N" & NewRw).Value = .Range("L" & i).Value wsOutput.Range("O" & NewRw).Value = .Range("M" & i).Value wsOutput.Range("P" & NewRw).Value = .Range("N" & i).Value wsOutput.Range("Q" & NewRw).Value = .Range("O" & i).Value wsOutput.Range("U" & NewRw).Value = "TC" NewRw = NewRw + 1 Next i End With 'START THE VLOOKUP NewRw = 2 With wsInPutL ' find the last row uccsosor = wsOutput.Cells(wsOutput.Rows.Count, "A").End(xlUp).Row 'find the last row in the last_meeting excel for the vlookup range uccsosor_comment = .Cells(.Rows.Count, "A").End(xlUp).Row For i = 2 To uccsosor On Error Resume Next 'if error, the code will go on anyway 'Result = Application.WorksheetFunction.Vlookup ( lookup_value, table_array, col_index_num, [range_lookup] ) wsOutput.Range("R" & NewRw).Value = Application.WorksheetFunction.VLookup(wsOutput.Range("D" & NewRw).Value, .Range("D2:R" & uccsosor_comment), 15, False) NewRw = NewRw + 1 Next i End With 'finish with vlookup End Sub


    My question is, do you know a faster way to combine 4xls in 8sheets (total 32 sheets) together in a faster way?

    I am thinking of a simply copy entire sheet function, so the new code will be:

    Color the row, copy entire sheet, color next row, copy entire sheet and so on 4 times, then VLOOKUP. THe problem with this is that i do some extra things in the middle of each copy in wsOutput.Range
     D/E/F columns... i do not know how this could be done in an entire sheet copy.

    If somebody has a better idea, please share with me. Better would be with code so if possible to mix the entire sheet copy plus the D/E/F column changes.

    Many thanks in advance!


    • Edited by hlpbob007 Wednesday, October 7, 2015 11:15 AM font/size was missmatch
    Wednesday, October 7, 2015 11:12 AM

Answers

  • Hi hlpbobo007,

    >>Color the row, copy entire sheet, color next row, copy entire sheet and so on 4 times, then VLOOKUP. THe problem with this is that i do some extra things in the middle of each copy in wsOutput.Range
     D/E/F columns... i do not know how this could be done in an entire sheet copy.<<

    Based on the code, the value on column D/E/F depends on other cells. We can write a formula to valuate the value instead.

    And to copy the entire sheet, we can use Worksheet.UsersRange.Copy.

    Regards & Fei


    We are trying to better understand customer views on social support experience, so your participation in this interview project would be greatly appreciated if you have time. Thanks for helping make community forums a great place.
    Click HERE to participate the survey.

    Thursday, October 8, 2015 5:16 AM
    Moderator