Conditionally Copy rows from Single Sheet to multiple Sheet

[AnilPullagura]

Hey Pros,

Need a help for the below scenario:

I have a spreadsheet which has zip codes in Column J. I also have sheets named with Zip Codes.

I need a macro that checks the Zipcode in cell J2 of Sheet1, matches the corresponding sheetname, then copies entire row from Sheet1 for that zip code and pastes them to the corresponding sheet.

There are more than one entry for a zipcode in Sheet1. So all the rows matching the Zipcode to SheetName should be copied.

I did try to write, but was unable to write for the Range of values. However if I hardcode for a single zipcode, the below code works.

Can i get any help in for the entire range of J2:J1385 of Sheet1

Below is my code which works for hard coded zip code of 21216.

Sub CpyToMultipleSheets()
Set i = Sheets("Sheet1")
Set e = Sheets("21216")
Dim d
Dim j
d = 1
j = 2


Do Until IsEmpty(i.Range("J" & j))

If i.Range("J" & j) = "21216" Then
d = d + 1
e.Rows(d).Value = i.Rows(j).Value

End If
j = j + 1
Loop
End Sub

Thanks,
Anil

 

[AnilPullagura]

BUMP....., this is pretty urgent for me now... Please guide me

 

[Warship]

Try:

Sub CopyZips()
  Dim sh As Worksheet, DataTable As Range, z As Long
  Set DataTable = Sheets("sheet1").Range("J2:J" & Sheets("sheet1").Cells(Rows.Count, "J").End(xlUp).Row)
  For Each sh In ThisWorkbook.Sheets
    For z = 1 To DataTable.Rows.Count
      If CStr(DataTable.Cells(z, 1)) = sh.Name Then
        DataTable.Cells(z, 1).EntireRow.Copy sh.Cells(sh.Cells(Rows.Count, "J").End(xlUp).Row + 1, 1)
      End If
    Next z
  Next
End Sub

 

[Warship]

This is better:
SortSheets courtesy of JWalk

Option Explicit

Sub CopyZips()
  Dim Sh As Worksheet, DataTable As Range, z As Long
  Application.ScreenUpdating = False
  Set DataTable = Sheets("sheet1").Range("J2:J" & Sheets("sheet1").Cells(Rows.Count, "J").End(xlUp).Row)
  For z = 1 To DataTable.Rows.Count
    If Not SheetExists(Format(DataTable.Cells(z, 1), "00000")) Then
      Sheets.Add
      ActiveSheet.Name = Format(DataTable.Cells(z, 1), "00000")
    End If
    Set Sh = Worksheets(Format(DataTable.Cells(z, 1), "00000"))
    DataTable.Cells(z, 1).EntireRow.Copy Sh.Cells(Sh.Cells(Rows.Count, "J").End(xlUp).Row + 1, 1)
  Next z
  SortSheets
End Sub

Function SheetExists(ShTest As String) As Boolean
  Dim testSh As Worksheet
  SheetExists = False
  On Error Resume Next
  Set testSh = Worksheets(ShTest)
  On Error GoTo 0
  If Not testSh Is Nothing Then SheetExists = True
End Function

Sub SortSheets()
  ' This routine sorts the sheets of the
  ' active workbook in ascending order.
  Dim SheetNames() As String
  Dim i As Integer
  Dim SheetCount As Integer
  Dim VisibleWins As Integer
  Dim Item As Object
  Dim OldActive As Object
  On Error Resume Next
  SheetCount = ActiveWorkbook.Sheets.Count
  If Err <> 0 Then Exit Sub ' No active workbook
  ' Check for protected workbook structure
  If ActiveWorkbook.ProtectStructure Then
    MsgBox ActiveWorkbook.Name & " is protected.", _
    vbCritical, "Cannot Sort Sheets."
  Exit Sub
  End If
  ' Disable Ctrl+Break
  Application.EnableCancelKey = xlDisabled
  ' Get the number of sheets
  SheetCount = ActiveWorkbook.Sheets.Count
  ' Redimension the array
  ReDim SheetNames(1 To SheetCount)
  ' Store a reference to the active sheet
  Set OldActive = ActiveSheet
  ' Fill array with sheet names and hidden status
  For i = 1 To SheetCount
    SheetNames(i) = ActiveWorkbook.Sheets(i).Name
  Next i
  ' Sort the array in ascending order
  Call BubbleSort(SheetNames)
  ' Turn off screen updating
  Application.ScreenUpdating = False
  ' Move the sheets
  For i = 1 To SheetCount
    ActiveWorkbook.Sheets(SheetNames(i)).Move _
    ActiveWorkbook.Sheets(i)
  Next i
  ' Reactivate the original active sheet
  OldActive.Activate
End Sub

Sub BubbleSort(List() As String)
  ' Sorts the List array in ascending order
  Dim First As Integer, Last As Integer
  Dim i As Integer, j As Integer
  Dim Temp
  First = LBound(List)
  Last = UBound(List)
  For i = First To Last - 1
    For j = i + 1 To Last
      If List(i) > List(j) Then
        Temp = List(j)
        List(j) = List(i)
        List(i) = Temp
      End If
    Next j
  Next i
End Sub