PDA

View Full Version : Pasting Rows from one Table to another



b4tmast
01-16-2016, 01:00 AM
I have Table1 with 17 columns and several hundred rows. I am trying to paste specific rows in a specific order to Table2 - they must always be in specific rows on Table2 (see code/spreadsheet). My problem is that on Table2 I need to have an index column on the left (for other spreadsheets in the program). I can't get it to paste one column over. It keeps pasting to the left column like Table1. I've tried different methods and still the same results. Any suggestions? Also, the method that I'm using to paste to Table2 seems very sloppy, inefficent and crude - I could use helpful suggestions. Oh yeah, I'm a complete newbie. Thanks in advance.



Option Explicit


Sub PopulateSheet2()


Dim wsh As Worksheet
Dim wsh2 As Worksheet
Dim i As Long
Dim Lr As Long
Dim Table2 As Object
' Initalize variables
Set wsh = Sheets("Sheet1")
Set wsh2 = Sheets("Sheet2")




With Sheets("Sheet1")
Lr = .Range("B2").End(xlDown).Row

For i = 2 To Lr
If .Cells(i, "D") = "Master" And .Cells(i, "E") Like "*Active*" Then
' wsh.Range("Table1").AdvancedFilter Action:=xlFilterCopy, _
' CriteriaRange:=wsh.Rows(i), CopytoRange:=wsh2.Range("B2:R2"), Unique:=False
wsh.Rows(i).Copy Destination:=wsh2.Rows(2)
End If
If .Cells(i, "D") Like "*Chief Mate*" And .Cells(i, "E") Like "*Active*" Then
wsh.Rows(i).Copy Destination:=wsh2.Rows(3)
End If
If .Cells(i, "D") Like "*Second Mate*" And .Cells(i, "E") Like "*Active*" Then
wsh.Rows(i).Copy wsh2.Rows(4)
End If
If .Cells(i, "D") = "Third Mate" And .Cells(i, "E") Like "*Active*" Then
wsh.Rows(i).Copy wsh2.Rows(5)
End If
If .Cells(i, "D") = "Third Mate RO" And .Cells(i, "E") Like "*Active*" Then
wsh.Rows(i).Copy wsh2.Rows(6)
End If
If .Cells(i, "D") Like "*Bosun AB*" And .Cells(i, "E") Like "*Active*" Then
wsh.Rows(i).Copy wsh2.Rows(7)
End If
If .Cells(i, "D") Like "*AB Deck Maintenance (1)*" And .Cells(i, "E") Like "*Active*" Then
wsh.Rows(i).Copy wsh2.Rows(8)
End If
If .Cells(i, "D") Like "*AB Deck Maintenance (2)*" And .Cells(i, "E") Like "*Active*" Then
wsh.Rows(i).Copy wsh2.Rows(9)
End If
If .Cells(i, "D") Like "*AB Watch 8X12*" And .Cells(i, "E") Like "*Active*" Then
wsh.Rows(i).Copy wsh2.Rows(10)
End If
If .Cells(i, "D") Like "*AB Watch 12x4*" And .Cells(i, "E") Like "*Active*" Then
wsh.Rows(i).Copy wsh2.Rows(11)
End If
If .Cells(i, "D") Like "*AB Watch 4x8*" And .Cells(i, "E") Like "*Active*" Then
wsh.Rows(i).Copy wsh2.Rows(12)
End If
If .Cells(i, "D") Like "*Chief Engineer*" And .Cells(i, "E") Like "*Active*" Then
wsh.Rows(i).Copy wsh2.Rows(13)
End If
If .Cells(i, "D") Like "*First Engineer*" And .Cells(i, "E") Like "*Active*" Then
wsh.Rows(i).Copy wsh2.Rows(14)
End If
If .Cells(i, "D") Like "*Second Engineer*" And .Cells(i, "E") Like "*Active*" Then
wsh.Rows(i).Copy wsh2.Rows(15)
End If
If .Cells(i, "D") Like "*Third Engineer*" And .Cells(i, "E") Like "*Active*" Then
wsh.Rows(i).Copy wsh2.Rows(16)
End If
If .Cells(i, "D") Like "*Deck Engine Utility (1)*" And .Cells(i, "E") Like "*Active*" Then
wsh.Rows(i).Copy wsh2.Rows(17)
End If
If .Cells(i, "D") Like "*Deck Engine Utility (2)*" And .Cells(i, "E") Like "*Active*" Then
wsh.Rows(i).Copy wsh2.Rows(18)
End If
If .Cells(i, "D") Like "*Steward Baker*" And .Cells(i, "E") Like "*Active*" Then
wsh.Rows(i).Copy wsh2.Rows(19)
End If
If .Cells(i, "D") Like "*Chief Cook*" And .Cells(i, "E") Like "*Active*" Then
wsh.Rows(i).Copy wsh2.Rows(20)
End If
If .Cells(i, "D") Like "*Steward Assistant*" And .Cells(i, "E") Like "*Active*" Then
wsh.Rows(i).Copy wsh2.Rows(21)
End If

' Seems very inefficient, slow and sloppy...
Next i
End With


End Sub

b4tmast
01-16-2016, 03:23 AM
Sorry guys...

b4tmast
01-16-2016, 04:16 AM
Solved!

This is the best code I could come up with. Any suggestions for making it more efficient, less bulky, etc. would be appreciated. Thanks.


Sub CopyRows()


Dim wsh As Worksheet
Dim wsh2 As Worksheet
Dim i As Long
Dim Lr As Long


' Initalize variables
Set wsh = Sheets("Sheet1")
Set wsh2 = Sheets("Sheet2")

With Sheets("Sheet1")
Sheets("Sheet1").Select
' Find the last row of data
Lr = .Range("B2").End(xlDown).Row
' Loop through each row
For i = 2 To Lr
' Decide if to copy based on column C & D
If .Cells(i, "C") = "Master" And .Cells(i, "D") Like "*Active*" Then
.Cells(i, 1).Resize(1, 17).Copy
Sheets("Sheet2").Select
Sheets("Sheet2").Range("B2").Select
ActiveSheet.Paste
End If
If .Cells(i, "C") Like "*Chief Mate*" And .Cells(i, "D") Like "*Active*" Then
.Cells(i, 1).Resize(1, 17).Copy
Sheets("Sheet2").Select
Sheets("Sheet2").Range("B3").Select
ActiveSheet.Paste
End If
If .Cells(i, "C") Like "*Second Mate*" And .Cells(i, "D") Like "*Active*" Then
.Cells(i, 1).Resize(1, 17).Copy
Sheets("Sheet2").Select
Sheets("Sheet2").Range("B4").Select
ActiveSheet.Paste
End If
If .Cells(i, "C") = "Third Mate RO" And .Cells(i, "D") Like "*Active*" Then
.Cells(i, 1).Resize(1, 17).Copy
Sheets("Sheet2").Select
Sheets("Sheet2").Range("B5").Select
ActiveSheet.Paste
End If
If .Cells(i, "C") = "Third Mate" And .Cells(i, "D") Like "*Active*" Then
.Cells(i, 1).Resize(1, 17).Copy
Sheets("Sheet2").Select
Sheets("Sheet2").Range("B6").Select
ActiveSheet.Paste
End If
'sloppy, but, it's the best I could come up with...


Next i
End With
End Sub