Copy specific cells based on value in the same row in sheet1(table1) and paste into sheet2(table2) next available row

pstamper

New Member
Joined
Mar 12, 2022
Messages
4
Office Version
  1. 365
Platform
  1. Windows
  2. Mobile
  3. Web
This code works, but it puts the values at the bottom of Sheet2(Table2), instead of next available row in table2. Any suggestions would be appreciated. Thanks

VBA Code:
Sub Macro()

  Dim ws As Worksheet
  Set ws = ThisWorkbook.Sheets("Sheet2")
  Dim LastRow As Long
  Dim s As Long
  Dim myRow As Long
          
                   
      s = ws.Range("A" & Application.Rows.Count).End(xlUp).Row
              
      LastRow = Sheets("Sheet1").Cells(Rows.Count, "I").End(xlUp).Row
                     
          For myRow = 2 To LastRow
              If Sheets("Sheet1").Cells(myRow, "I") = "INACTIVE" Then
                 ws.Range("A" & s + 1) = Sheets("Sheet1").Cells(myRow, "A")
                 ws.Range("B" & s + 1) = Sheets("Sheet1").Cells(myRow, "B")
                 ws.Range("C" & s + 1) = Sheets("Sheet1").Cells(myRow, "C")
                 ws.Range("D" & s + 1) = Sheets("Sheet1").Cells(myRow, "I")
              End If
          Next myRow           
        
                  

End Sub
 

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes
Hi, your issue sounds similar to the one found here - Pasting in transpose
If that is not the case, upload an image of the table and I will test it.
 
Upvote 0
Hi, your issue sounds similar to the one found here - Pasting in transpose
If that is not the case, upload an image of the table and I will test it.
Test Book_Copy&Paste Example.xlsm
ABCDEFGHI
5Emp No.Last NameFirst NameMiddle NameSexMarriedPhone No.AddressStatus
61234ONETESTMEMALEYES(555) 555-5555USACTIVE
71235TWOTESTMEFEMALEYES(777) 777-7777USACTIVE
81236THREETESTMEMALENO(888) 888-8888USINACTIVE
91237FOURTESTMEMALEYES(222) 222-2222USACTIVE
Sheet1


Test Book_Copy&Paste Example.xlsm
ABCD
1Emp No.Last NameFirst NameStatus
2
Sheet2
 
Upvote 0
Test Book_Copy&Paste Example.xlsm
ABCDEFGHI
5Emp No.Last NameFirst NameMiddle NameSexMarriedPhone No.AddressStatus
61234ONETESTMEMALEYES(555) 555-5555USACTIVE
71235TWOTESTMEFEMALEYES(777) 777-7777USACTIVE
81236THREETESTMEMALENO(888) 888-8888USINACTIVE
91237FOURTESTMEMALEYES(222) 222-2222USACTIVE
Sheet1


Test Book_Copy&Paste Example.xlsm
ABCD
1Emp No.Last NameFirst NameStatus
2
Sheet2
 
Upvote 0
Ok, this was a rough one. Your code is perfect. It looks like the table has two rows when you build it, the header and then first row. Since "s" is 2, ws.Range("A" & s + 1) is 2 + 1, so it's placing the data on row 3, outside the table. A simple fix, see below:

s = ws.Range("A" & Application.Rows.Count).End(xlUp).Row
If Range("A" & s) = "" And Range("B" & s) = "" Then 'If the lastrow is missing the No. and Last Name from the table, let's use it.
s = s - 1
End If
 
Upvote 0
If your issue is that you are getting the last row in the table instead of the last empty row in the table, then try this:

VBA Code:
Sub LastUsedRow()
    Dim s As Long
    Dim lstObj As ListObject
    Set lstObj = Worksheets("Sheet2").ListObjects("Table2")
    
    With lstObj
        If .ShowAutoFilter Then .AutoFilter.ShowAllData
        s = Worksheets("Sheet2").Range("Table2").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

    End With

End Sub
 
Upvote 0
This is the solution I was looking for. Thanks to VBasic2008.


VBA Code:
Option Explicit

Sub Macro()

    Dim sws As Worksheet: Set sws = ThisWorkbook.Worksheets("Sheet1")
    Dim stbl As ListObject: Set stbl = sws.ListObjects("Table1")
    
    Dim dws As Worksheet: Set dws = ThisWorkbook.Worksheets("Sheet2")
    Dim dtbl As ListObject: Set dtbl = dws.ListObjects("Table2")

    Dim sCell As Range
    Dim srrg As Range
    Dim drrg As Range
    Dim r As Long
    
    For Each sCell In stbl.ListColumns("Status").DataBodyRange
        r = r + 1
        If StrComp(CStr(sCell.Value), "INACTIVE", vbTextCompare) = 0 Then
            Set srrg = stbl.ListRows(r).Range
            Set drrg = dtbl.ListRows.Add.Range
            drrg.Cells(1).Value = srrg.Cells(1).Value
            drrg.Cells(2).Value = srrg.Cells(2).Value
            drrg.Cells(3).Value = srrg.Cells(3).Value
            drrg.Cells(4).Value = srrg.Cells(9).Value
        End If
    Next sCell

End Sub
 
Upvote 0
Solution

Forum statistics

Threads
1,223,234
Messages
6,170,891
Members
452,366
Latest member
TePunaBloke

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top