Code Optimization - Copy cells from one sheet to another - remove blank rows

snuffnchess

New Member
Joined
May 15, 2015
Messages
25
While I was able to get code to work and do what it is I am wanting, something tells me that there are much better ways to do what I am trying to accomplish?

Essentially, I am wanting to copy the contents of cells from "ClientDB" BJ4:BK(lastrow), BN4:BO(lastrow) - and so on

and then have those contents paste only into column A and B of the Birthdays tab. Essentially I want to be able to enter in the month (for example May) and have an auto Filter of everybody whose birthday is that month.

To Copy the persons Name and DOB I am using:

Code:
[/COLOR]Sub Macro1()

Dim bd As Worksheet
Set bd = Worksheets("Birthdays")
Dim CDB As Worksheet
Set CDB = Worksheets("ClientDB")
Dim lastrow As Long
Dim lastbdrow As Long


With Sheets("Birthdays")
    If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
        lastbdrow = .Cells.Find(What:="*", _
                      After:=.Range("A1"), _
                      Lookat:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Row
    Else
        lastbdrow = 1
    End If
End With


With Sheets("ClientDB")
    If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
        lastrow = .Cells.Find(What:="*", _
                      After:=.Range("A1"), _
                      Lookat:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Row
    Else
        lastrow = 1
    End If
End With




    Dim bdRow As Long
    bdRow = Application.WorksheetFunction.CountA(bd.Range("A:A")) + 1
    
    Sheets("Birthdays").Select
    Range("A2:B" & lastrow).ClearContents
    
    
    


    Sheets("ClientDB").Select
    Range("BI4:BJ" & lastrow).Select
    Selection.Copy
    Sheets("Birthdays").Select
    Range("A2").Select
    bd.Cells(bdRow, 1).Select
    ActiveSheet.Paste
   ' Sheets("ClientDB").Select
   ' Range("BN4:BO4").Select
   ' Range(Selection, Selection.End(xlDown)).Select
   ' Selection.Copy
   ' bdRow = Application.WorksheetFunction.CountA(bd.Range("A:A")) + 1
   ' Sheets("Birthdays").Select
   ' bd.Cells(bdRow, 1).Select
   ' ActiveSheet.Paste

End Sub[COLOR=#333333]

And then to eliminate the blank rows I am using

Code:
[/COLOR]Sub Select_Blank_Rows()

Dim rRow As Range
Dim rSelect As Range
Dim rSelection As Range




Dim lastrow As Long


With Sheets("Birthdays")
    If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
        lastrow = .Cells.Find(What:="*", _
                      After:=.Range("A1"), _
                      Lookat:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Row
    Else
        lastrow = 1
    End If
End With


'MsgBox lastrow


If Selection.Cells.Count = 1 Then
    Set rSelection = Range("A1:B" & lastrow)
    Else
    Set rSelection = Range("A1:B" & lastrow)
End If




  For Each rRow In rSelection.Rows
    If WorksheetFunction.CountA(rRow) = 0 Then
      If rSelect Is Nothing Then
        Set rSelect = rRow
      Else
        Set rSelect = Union(rSelect, rRow)
      End If
    End If
  Next rRow
  
  rSelect.Rows.Delete Shift:=xlShiftUp
  
  

End Sub[COLOR=#333333]
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
31,908
Office Version
365
Platform
Windows
Cross posted https://www.excelforum.com/excel-programming-vba-macros/1274584-code-optimization-copy-cells-from-one-sheet-to-another-remove-blank-rows.html

While we do not prohibit Cross-Posting on this site, we do ask that you please mention you are doing so and provide links in each of the threads pointing to the other thread (see rule 13 here along with the explanation: Forum Rules).
This way, other members can see what has already been done in regards to a question, and do not waste time working on a question that may already be answered.
 

snuffnchess

New Member
Joined
May 15, 2015
Messages
25
Cross posted https://www.excelforum.com/excel-programming-vba-macros/1274584-code-optimization-copy-cells-from-one-sheet-to-another-remove-blank-rows.html

While we do not prohibit Cross-Posting on this site, we do ask that you please mention you are doing so and provide links in each of the threads pointing to the other thread (see rule 13 here along with the explanation: Forum Rules).
This way, other members can see what has already been done in regards to a question, and do not waste time working on a question that may already be answered.
Completely understood. I will make sure to do that going forward.
 

Forum statistics

Threads
1,081,415
Messages
5,358,533
Members
400,502
Latest member
price83

Some videos you may like

This Week's Hot Topics

  • VBA (Userform)
    Hi All, I just would like to know why my code isn't working. Here is my VBA code: [CODE=vba]Private Sub OKButton_Click() Dim i As Integer...
  • List box that changes fill color
    Hello, I have gone through so many pages trying to figure this out. I have a 2020 calendar that depending on the day needs to have a certain...
  • Remove duplicates and retain one. Cross-linked cases
    Hi all I ran out of google keywords to use and still couldn't find a reference how to achieve the results of a single count. It would be great if...
  • VBA Copy and Paste With Duplicates
    Hello All, I'm in need of some input. My VBA skills are sub-par at best. I've assembled this code from basic research and it works but is...
  • Macro
    is it possible for a macro to run if the active cell value is different to the value above it
  • IF DATE and TIME
    I currently use this to check if date has passed but i also need to set a time on it too. Is it possible? [CODE=vba]=IF(B:B>TODAY(),"Not...
Top