Move Select Rows and Columns to Sheet 2

[kisinana]

I need some help please. I presently have a worksheet which has multiple rows and columns for a overhaul. I need to have a progress sheet just to send out updates
At present I just
[VBA]
Sub copySht1toSht2()
Sheets("Overhaul").Columns("A").Copy Sheets("Progress").Columns("A")
Sheets("Overhaul").Columns("B").Copy Sheets("Progress").Columns("B")
Sheets("Overhaul").Columns("F").Copy Sheets("Progress").Columns("C")
Sheets("Overhaul").Columns("G").Copy Sheets("Progress").Columns("D")

'
End Sub
[/VBA]
Then I go to Progress Sheet and delete all the rows below the last entry from column F which is now Column C. I am trying to figure out how I find the last row in column F which has decimals only in it, and then only copy A, B, F and G down to this row. I have been searching through the database but I feel I am getting sidertracked.
Thanks in advance.

[arnelgp]

Public Sub OverHaulToProgress()


    Const srcSheet As String = "OverHaul"
    Const trgSheet As String = "Progress"
    
    Dim srcColumn As Variant
    Dim trgColumn As Variant
    Dim last_row As Long
    Dim i As Integer
    Dim ColFrom As Integer
    Dim ColTo As Integer
    Dim iX As Long
    Dim sht1 As Worksheet
    Dim sht2 As Worksheet
    
    srcColumn = Array(1, 2, 6, 7)
    trgColumn = Array(1, 2, 3, 4)


    Set sht1 = Worksheets(srcSheet)
    Set sht2 = Worksheets(trgSheet)
    
    With sht2
        last_row = .Cells(.Rows.Count, 3).End(xlUp).Row
    End With
    If last_row > 1 Then
        last_row = last_row + 1
    End If
    For i = 0 To UBound(srcColumn)
        ColFrom = srcColumn(i)
        ColTo = trgColumn(i)
        sht2.Cells(last_row, ColTo).Select
        With sht1
            iX = .Cells(.Rows.Count, ColFrom).End(xlUp).Row
            .Range(.Cells(1, ColFrom), .Cells(iX, ColFrom)).Copy
        End With
        sht2.Paste
    Next i
End Sub

[kisinana]

Hi Arnelgp Thanks for the reply
I got a Runtime error "Select method of Range Class Failed on the line "sht2.Cells(last_row, ColTo).Select" I will look at information for range class failure later as i do want to understand this better.
I also forgot to mention that I have Row Headers and need the columns to be the same width they were on Sheet 1
Thanks very much

[kisinana]

Here is a small sample file contains multiple columns and rows

[jolivanes]

Could you not copy the used range over and delete the columns and rows you don't need?

Sub Maybe()
Dim lr As Long, arrO, arrP, i As Long
lr = Cells(Rows.Count, 6).End(xlUp).Row
arrO = Array(1, 2, 6, 7)
    With Sheets("Progress")
        For i = 1 To 4
            .Cells(1, i).Resize(lr).Value = Sheets("Overhaul").Cells(1, arrO(i - 1)).Resize(lr).Value
            .Columns(i).ColumnWidth = Sheets("Overhaul").Columns(arrO(i - 1)).ColumnWidth
        Next i
    End With
End Sub

BTW, in your first post where you have square brackets with VBA in it, change the word VBA to Code.

[kisinana]

Thanks jolivanes
Yes that does exactly what was needed. Quick question using this Sub if I need this on another workbook to do something similar, I would just need to change sheet names, array numbers, and row count to whichever is my target row? By increasing the array to 6 columns I would also change i=1 to 6?
Thanks in advance for your help.

[arnelgp]

Public Sub OverHaulToProgress()
    Const srcSheet As String = "OverHaul"
    Const trgSheet As String = "Progress"
    Dim srcColumn As Variant
    Dim trgColumn As Variant
    Dim last_row As Long
    Dim i As Integer
    Dim ColFrom As Integer
    Dim ColTo As Integer
    Dim iX As Long
    Dim sht1 As Worksheet
    Dim sht2 As Worksheet
    Dim sht As Worksheet
    
    srcColumn = Array(1, 2, 6, 7)
    trgColumn = Array(1, 2, 3, 4)


    For Each sht In ThisWorkbook.Worksheets
        If UCase(sht.Name) = UCase(srcSheet) Then
            Set sht1 = sht
        Else
            If UCase(sht.Name) = UCase(trgSheet) Then
                Set sht2 = sht
            End If
        End If
    Next sht
    
    With sht2
        last_row = .Cells(.Rows.Count, 3).End(xlUp).Row
    End With
    If last_row > 1 Then
        last_row = last_row + 1
    End If
    For i = 0 To UBound(srcColumn)
        ColFrom = srcColumn(i)
        ColTo = trgColumn(i)
        With sht1
            iX = .Cells(.Rows.Count, ColFrom).End(xlUp).Row
            .Range(.Cells(1, ColFrom), .Cells(iX, ColFrom)).Copy
        End With
        sht2.Cells(last_row, ColTo).PasteSpecial Paste:=xlValue
    Next i
End Sub

[jolivanes]

Yes on all counts.
Instead of deleting rows after pasting into a different sheet, this just copies the required amount of rows.
The "arrO" Array has the Columns (in numbers) that need to be copied from "Overhaul" Sheet.
The "i = 1 To 6" as you mentioned works only if the Columns are adjacent to each other of course.

[kisinana]

Thanks Jolivanes and Arnelgp. Having the 2 codes that both work allows me to walk through each and learn more about VBA code. That is thing with it very rarely is there only one way to do something.
Thanks again for all your help.

[jolivanes]

Thank you for letting us know that all is well.
Good luck and stay safe.

[kisinana]

Hi again. I tried Jolivanes formula and it worked well. I found though that it did not transfer highlighted cell colors. Do I just need to add a range pastespecial?

[jolivanes]

The code I supplied was not meant to copy formats because it was not asked for and the attachment did not show any colors.
If you need that done the code need to be changed as my suggestion does not copy and paste.
If I have some time tomorrow I'll have a look.
Is there anything else that needs to be added or changed?

[jolivanes]

Remember, you asked for cell colors only.

OK, I took some time from my much needed beauty sleep.

Sub Maybe()
Dim lr As Long, arrO, arrP, i As Long
lr = Cells(Rows.Count, 6).End(xlUp).Row
arrO = Array(1, 2, 6, 7)
    With Sheets("Progress")
        For i = 1 To 4
            With .Cells(1, i).Resize(lr)
                .Value = Sheets("Overhaul").Cells(1, arrO(i - 1)).Resize(lr).Value
                .Interior.Color = Sheets("Overhaul").Cells(1, arrO(i - 1)).Resize(lr).Interior.Color
            End With
            .Columns(i).ColumnWidth = Sheets("Overhaul").Columns(arrO(i - 1)).ColumnWidth
        Next i
    End With
End Sub

Does this give you the result you're after?

[jolivanes]

Or like this.

Sub Maybe_2()
Dim lr As Long, arrO, arrP, i As Long, j As Long
lr = Cells(Rows.Count, 6).End(xlUp).Row
arrO = Array(1, 2, 6, 7)
j = 1
    With Sheets("Overhaul")
        For i = LBound(arrO) To UBound(arrO)
            .Cells(1, arrO(i)).Resize(lr).Copy Sheets("Progress").Cells(1, j)
                Sheets("Progress").Cells(1, j).EntireColumn.ColumnWidth = Sheets("Overhaul").Columns(arrO(i)).ColumnWidth
            j = j + 1
        Next i
    End With
End Sub

[kisinana]

Thanks jolivanes. Sorry the reason I did not mention it was because I only highlight the odd comment when I want to draw attention to it. It was only after using it I noticed. Thanks again for your input.

[jolivanes]

No problem.
Thanks for letting us know.
Stay safe and good luck.

[kisinana]

Sorry to bring this up again, however I tried both the suggestions from jolivanes for highlighting and got a 438 error on line " .Interior.Color = Sheets("Overhaul").Cells(1, arrO(i - 1)).Resize(lr).Interior.Color" I tried that maybe the end with was in the wrong place or that it should have been a color descriptor. I just don't see what I am missing when I read it it seems to follow through. The second sample also produces an error code. i tried adjusting the first example because without the highlighting I could follow through the code. There is no rush on this as I am not using it for a while yet. Thanks in advance

[jolivanes]

Both suggestions work perfect on your supplied attachment from Post #4 here.
Might be an Excel version problem. This was used on Excel 2007. Maybe someone else can shed a light on that.
Two more possibilities you can try.

Sub Maybe_3()
Dim lr As Long, arrO, i As Long, j As Long
lr = Sheets("Overhaul").Cells(Rows.Count, 6).End(xlUp).Row
arrO = Array(1, 2, 6, 7)
j = 1
Application.ScreenUpdating = False
    For i = LBound(arrO) To UBound(arrO)
        Sheets("Overhaul").Cells(1, arrO(i)).Resize(lr).Copy
            With Sheets("Progress").Cells(1, j)
                .PasteSpecial xlPasteAll
                .PasteSpecial xlPasteColumnWidths
            End With
        j = j + 1
    Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Sub Maybe_4()
Dim lr1 As Long, lr2 As Long
Application.ScreenUpdating = False
Sheets("Overhaul").Cells(1).CurrentRegion.Copy
    With Sheets("Progress")
        With .Cells(1)
            .PasteSpecial xlPasteAll
            .PasteSpecial xlPasteColumnWidths
        End With
            lr1 = .Cells(.Rows.Count, 6).End(xlUp).Row
            lr2 = .Range("A:G").Find("*", , xlValues, , xlByRows, xlPrevious).Row
        .Cells(lr1 + 1, 1).Resize(lr2 - lr1, 7).Delete Shift:=xlUp
        .Range("C:E").Delete
    End With
Application.ScreenUpdating = True
End Sub

[kisinana]

Thanks Jolivanes 4th sample was the charm. The first 3 all came back with the same error. I originally started the file on MS2013 and am now using MS2016 so i am not sure why the last one worked but it does. Thank you for the time and effort. I am still working through understanding how it works but I am figuring it out a bit at a time. Thanks very much once again and stay safe.
Kisinana

[jolivanes]

Thanks for the update.
Good luck