Neighborhood directory

[JimS63]

Sunday School Test.xlsm
	D	E	F	G	H	I	J	K	L	M
1	E-Mail	Phone	Name	Birthday	E-mail	Phone	Address	City	State	Zip
2	Glen@mail.com	816-552-	Cindy	1-Feb	Cindy@mail.com	816-557	17 Elm	Raymore	MO	64083
3	John@mail.com	816-553	Susan	21-Nov	Susan@mail.com	816-558	18 Ash	Peculiar	MO	64078
4	Janie@mail.com	816-554					19 Walnut	Raymore	MO	64078
5	Glenna@mail.com	816-555					20 Oak	Raymore	MO	64083
6	Jim@mail.com	816-556	Kathy	4-Nov	Kathy@mail.com	816-559	21 Pecan	Raymore	MO	64083
Contacts

I have this worksheet and I want to create a birthday list on a second worksheet.

My output should be in the form
Jan 4 First and Last Name
Feb 7 First and Last Name

I am trying to do it with copying only non blank cells and the cells next to them onto another table on the second sheet.

Here is my code

Sub CopyAndPasteNonBlanks()
Dim rng As Range

Set rng = Range("C2:C50").SpecialCells(xlCellTypeConstants)
rng.Copy Range("O2")

Set rng = Range("B2:B50").SpecialCells(xlCellTypeConstants)
rng.Copy Range("P2")

Set rng = Range("A2:A50").SpecialCells(xlCellTypeConstants)
rng.Copy Range("Q2")


Set rng = Range("G2:G50").SpecialCells(xlCellTypeConstants)
rng.Copy Range("O7")

Set rng = Range("F2:F50").SpecialCells(xlCellTypeConstants)
rng.Copy Range("P7")

Set rng = Range("A2:A50").SpecialCells(xlCellTypeConstants)
rng.Copy Range("Q7")

End Sub

Here is my result

I need the code to find the first blank cell for the second set of names.
I also need the last names to only paste if the first name is not blank

Can one of you fine folks help me out?

I plan on using mail merge on this list into a Word document for printing.

 

[JimS63]

Sorry the mini sheet doesn't contain all the data

Sunday School Test.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M
1	Family Name	Given Name	Birthday	E-Mail	Phone	Name	Birthday	E-mail	Phone	Address	City	State	Zip
2	Adams	Glen	12-Sep	Glen@mail.com	816-552-	Cindy	1-Feb	Cindy@mail.com	816-557	17 Elm	Raymore	MO	64083
3	Smith	John	10-Nov	John@mail.com	816-553	Susan	21-Nov	Susan@mail.com	816-558	18 Ash	Peculiar	MO	64078
4	Davis	Janie	15-Sep	Janie@mail.com	816-554					19 Walnut	Raymore	MO	64078
5	Fowler	Glenna	25-Nov	Glenna@mail.com	816-555					20 Oak	Raymore	MO	64083
6	Weeks	Jim	22-Feb	Jim@mail.com	816-556	Kathy	4-Nov	Kathy@mail.com	816-559	21 Pecan	Raymore	MO	64083
Contacts

 

[Fluff]

How about

Sub CopyAndPasteNonBlanks()
   Dim NxtRw As Long
   
   With Range("C2:C50").SpecialCells(xlCellTypeConstants)
      .Copy Range("O2")
      .Offset(, -1).Copy Range("P2")
      .Offset(, -2).Copy Range("Q2")
   End With
   
   NxtRw = Range("O" & Rows.count).End(xlUp).Offset(1).Row
   
   With Range("G2:G50").SpecialCells(xlCellTypeConstants)
      .Copy Range("O" & NxtRw)
      .Offset(, -1).Copy Range("P" & NxtRw)
      .Offset(, -6).Copy Range("Q" & NxtRw)
   End With
End Sub

 

[mumps]

Create a sheet named "Birthdays" and place the headers in row 1. Then try this macro:

Sub CreateBirthdayList()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet, v As Variant, i As Long
    Set srcWS = Sheets("Contacts")
    Set desWS = Sheets("Birthdays")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    v = srcWS.Range("A2", srcWS.Range("C" & Rows.Count).End(xlUp)).Value
    For i = LBound(v) To UBound(v)
        If v(i, 2) <> "" Then
            With desWS
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 3).Value = Array(v(i, 3), v(i, 2), v(i, 1))
            End With
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

 

[JimS63]

Thanks for the code.

That worked for Column B and C but did not give me the birthdays of spouses in Column F and G. This is where my coding falls short. I don't need the spouses together if that helps.

 

[JimS63]

How about

Sub CopyAndPasteNonBlanks()
   Dim NxtRw As Long
  
   With Range("C2:C50").SpecialCells(xlCellTypeConstants)
      .Copy Range("O2")
      .Offset(, -1).Copy Range("P2")
      .Offset(, -2).Copy Range("Q2")
   End With
  
   NxtRw = Range("O" & Rows.count).End(xlUp).Offset(1).Row
  
   With Range("G2:G50").SpecialCells(xlCellTypeConstants)
      .Copy Range("O" & NxtRw)
      .Offset(, -1).Copy Range("P" & NxtRw)
      .Offset(, -6).Copy Range("Q" & NxtRw)
   End With
End Sub

This one worked perfect! Thank you so much.

Is there a way to put it onto a different worksheet?

 

[mumps]

This should do it:

Sub CreateBirthdayList()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet, v As Variant, i As Long
    Set srcWS = Sheets("Contacts")
    Set desWS = Sheets("Birthdays")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    v = srcWS.Range("A2", srcWS.Range("A" & Rows.Count).End(xlUp)).Resize(, 7).Value
    For i = LBound(v) To UBound(v)
        If v(i, 2) <> "" Then
            With desWS
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 5).Value = Array(v(i, 3), v(i, 2), v(i, 1), v(i, 6), v(i, 7))
            End With
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

Make sure you have a sheet named "Birthdays".

 

[Fluff]

Is there a way to put it onto a different worksheet?

Yup, like

Sub CopyAndPasteNonBlanks()
   Dim NxtRw As Long
   
   With Range("C2:C50").SpecialCells(xlCellTypeConstants)
      .Copy Sheets("Sheet1").Range("O2")
      .Offset(, -1).Copy Sheets("Sheet1").Range("P2")
      .Offset(, -2).Copy Sheets("Sheet1").Range("Q2")
   End With
   
   NxtRw = Sheets("Sheet1").Range("O" & Rows.count).End(xlUp).Offset(1).Row
   
   With Range("G2:G50").SpecialCells(xlCellTypeConstants)
      .Copy Sheets("Sheet1").Range("O" & NxtRw)
      .Offset(, -1).Copy Sheets("Sheet1").Range("P" & NxtRw)
      .Offset(, -6).Copy Sheets("Sheet1").Range("Q" & NxtRw)
   End With
End Sub

 

[JimS63]

Yup, like

Sub CopyAndPasteNonBlanks()
   Dim NxtRw As Long
  
   With Range("C2:C50").SpecialCells(xlCellTypeConstants)
      .Copy Sheets("Sheet1").Range("O2")
      .Offset(, -1).Copy Sheets("Sheet1").Range("P2")
      .Offset(, -2).Copy Sheets("Sheet1").Range("Q2")
   End With
  
   NxtRw = Sheets("Sheet1").Range("O" & Rows.count).End(xlUp).Offset(1).Row
  
   With Range("G2:G50").SpecialCells(xlCellTypeConstants)
      .Copy Sheets("Sheet1").Range("O" & NxtRw)
      .Offset(, -1).Copy Sheets("Sheet1").Range("P" & NxtRw)
      .Offset(, -6).Copy Sheets("Sheet1").Range("Q" & NxtRw)
   End With
End Sub

Thank you for all your help. Works a champ!

 

[Fluff]

Glad we could help & thanks for the feedback.