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

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

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