Copy Row based on Cell Value, Paste to Sheet based on location

[helpexcel]

Hi - i have data on sheet1 from A5 to O200. This data is divided at various points with subtotals. Right now i use 3 different versions of the same code to move a row to another sheet when Cloumn J = "Closed" the code for this is below. Is there a way to use only 1 code and move it to Sheet2 if Closed is found between rows 5 and 100, sheet3 for rows 101-150 and sheet4 for rows 151-200? thanks!

Dim sh1 As Worksheet, sh2 As WorksheetSet sh1 = Sheet1
Set sh2 = Sheet11


nextRow = sh2.Cells(sh2.Rows.Count, "A").End(xlUp).Row + 1


Dim rng As Range
Set rng = sh1.Range("B5:J100")


sh1.Range("B5:J100").AutoFilter 9, "Closed"
sh1.Range("B6:H100").SpecialCells(xlCellTypeVisible).Copy
sh2.Cells(nextRow, "A").PasteSpecial xlPasteValues


rng.SpecialCells(xlCellTypeVisible).ClearContents


sh1.AutoFilterMode = False

 

[DanteAmor]

Try this

Sub test()
  Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, sh4 As Worksheet
  Dim shs As Variant, rgs As Variant, nextRow As Long, rg2 As Variant
  Dim rng As Range, i As Long, rng2 As Range
  
  Application.ScreenUpdating = False
  Set sh1 = Sheet1
  shs = Array(Sheet11, Sheet13, Sheet14)
  rgs = Array("B5:J100", "B101:J150", "B151:J200")
  rg2 = Array("B6:H100", "B102:H150", "B153:H200")
  
  For i = 0 To UBound(shs)
    Set sh2 = shs(i)
    Set rng = sh1.Range(rgs(i))
    Set rng2 = sh1.Range(rg2(i))
    nextRow = sh2.Range("A" & Rows.Count).End(xlUp).Row + 1
    rng.AutoFilter 9, "Closed"
    rng2.SpecialCells(xlCellTypeVisible).Copy
    sh2.Cells(nextRow, "A").PasteSpecial xlPasteValues
  Next
  sh1.AutoFilterMode = False
  MsgBox "End"
End Sub

 

[helpexcel]

Thanks!

This code copies the "closed" row in range(b6:h100), but it also copies every row in the other ranges. Also, I tried adding rng2.SpecialCells(xlCellTypeVisible).ClearContents to delete the row from sheet1, but it didn't work.

 

[DanteAmor]

Thanks!

This code copies the "closed" row in range(b6:h100), but it also copies every row in the other ranges.

What do you mean by "copies every row in the other ranges"


In my tests, I copy visible data from row 6 through 100 on sheet 2, row 102 through 150 on sheet 3, and 152 through 200 on sheet 4.

 

[helpexcel]

right but the visible data in 102:150, and 151:200 shouldn't be copied, only the row that says "Closed" should be copied from those ranges. So if "closed" appears in row 115, that row and that row only would get copied. thanks!

 

[DanteAmor]

right but the visible data in 102:150, and 151:200 shouldn't be copied, only the row that says "Closed" should be copied from those ranges. So if "closed" appears in row 115, that row and that row only would get copied. thanks!

I still don't understand, the macro copies only the rows that contain "Closed".


You could share a file to check what you have.

You could upload a copy of your file to a free site such www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. If the workbook contains confidential information, you could replace it with generic data.

 

[helpexcel]

I figured out the issue. There are subtotals (blank rows & then values), so the autofilter isn't working on ranges 102:150 and 151:200. Those rows are all still visable so that's why it's copying them.

 

[DanteAmor]

My tests work, I'm just trying to guess how you have your information. Try this:

Sub test()
  Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, sh4 As Worksheet
  Dim shs As Variant, rgs As Variant, nextRow As Long, rg2 As Variant
  Dim rng As Range, i As Long, rng2 As Range
  
  Application.ScreenUpdating = False
  Set sh1 = Sheet1
  shs = Array(Sheet11, Sheet13, Sheet14)
  rgs = Array("B5:J100", "B101:J150", "B151:J200")
  rg2 = Array("B6:H100", "B102:H150", "B153:H200")
  
  For i = 0 To UBound(shs)
    Set sh2 = shs(i)
    Set rng = sh1.Range(rgs(i))
    Set rng2 = sh1.Range(rg2(i))
    nextRow = sh2.Range("A" & Rows.Count).End(xlUp).Row + 1
[COLOR=#0000ff]    If sh1.AutoFilterMode Then sh1.AutoFilterMode = False[/COLOR]
    rng.AutoFilter 9, "Closed"
    rng2.SpecialCells(xlCellTypeVisible).Copy
    sh2.Cells(nextRow, "A").PasteSpecial xlPasteValues
  Next
  sh1.AutoFilterMode = False
  Application.CutCopyMode = False
  MsgBox "End"
End Sub