Checking if an Excel range is empty in VBA

[Stepheny2k2]

Hi,

I’m struggling to find a solution to the following.

I am copying data from different tabs in an excel workbook to one tab so i can pivot off the combined dataset. The VBA code works but i would like to add a check for sheets which contain no data. If there is no data(other than a header row) I want it to ignore my copying logic.

Below is an extract from my VBA code which copies from one sheet to the summary sheet:

[COLOR=black][FONT=Verdana][SIZE=3][FONT=Times New Roman]' Copies All data added for May and pastes at the position one cell below April's dataset<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:office:office" /><o:p></o:p>[/FONT][/SIZE][/FONT][/COLOR][FONT=Verdana]
[COLOR=black][SIZE=3][FONT=Times New Roman]   Sheets("May 2010").Select<o:p></o:p>[/FONT][/SIZE][/COLOR]
[COLOR=black][SIZE=3][FONT=Times New Roman]   Range("A2").Select<o:p></o:p>[/FONT][/SIZE][/COLOR]
[COLOR=black][SIZE=3][FONT=Times New Roman]   Range(Selection, Selection.End(xlToRight)).Select<o:p></o:p>[/FONT][/SIZE][/COLOR]
[COLOR=black][SIZE=3][FONT=Times New Roman]   Range(Selection, Selection.End(xlDown)).Select<o:p></o:p>[/FONT][/SIZE][/COLOR]
[COLOR=black][SIZE=3][FONT=Times New Roman]   Selection.Copy<o:p></o:p>[/FONT][/SIZE][/COLOR]
[COLOR=black][SIZE=3][FONT=Times New Roman]   Sheets("full dataset").Select<o:p></o:p>[/FONT][/SIZE][/COLOR]
[COLOR=black][SIZE=3][FONT=Times New Roman]   ActiveSheet.Paste<o:p></o:p>[/FONT][/SIZE][/COLOR]
[COLOR=black][SIZE=3][FONT=Times New Roman]   Range("A281").Select<o:p></o:p>[/FONT][/SIZE][/COLOR]
[COLOR=black][SIZE=3][FONT=Times New Roman]   Selection.End(xlDown).Select<o:p></o:p>[/FONT][/SIZE][/COLOR]
[COLOR=black][SIZE=3][FONT=Times New Roman]   ActiveCell.Offset(1, 0).Select<o:p></o:p>[/FONT][/SIZE][/COLOR]
[/FONT]

The range lines will work as long as there is data in there. Otherwise it will presumably select 65000 blank rows.

Can anyone help me adapt the above code to check if the sheet contains no data(other than header row) before it tries to copy from it?

Thanks in advance,<!-- google_ad_section_end --> <o></o>
<o></o>

 

[MrKowz]

Try:

  Dim LR As Long
  Dim LC As Long
  LR = Sheets("May 2010").Range("A" & Rows.Count).End(xlUp).Row
  LC = Sheets("May 2010").Cells(1, Columns.Count).End(xlToLeft).Column
  Range(Cells(2, 1), Cells(LR, LC)).Copy Destination:=Sheets("Full Dataset").Range("A1")

 

[VoG]

You could test like this:

If WorksheetFunction.CountA(Cells) = 0 Then 'sheet empty

 

[Stepheny2k2]

Thanks MrKowz,

Your solution does work and is more efficient than my method. The only problem with it is that within the 'Destination:' it needs to specify a specific cell in the range.

Because I am copying multiple months into the summary I need to adapt your code so that it will offset by 1 after each paste. Before I was using:

[SIZE=3][FONT=Times New Roman]ActiveCell.Offset(1, 0).Select<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:office:office" /><o:p></o:p>[/FONT][/SIZE]

How can I do the same but within the copy and paste line?:

Range(Cells(2, 1), Cells(LR, LC)).Copy Destination:=Sheets("Full Dataset").Range("A1")

Thanks for all your help

Try:

  Dim LR As Long
  Dim LC As Long
  LR = Sheets("May 2010").Range("A" & Rows.Count).End(xlUp).Row
  LC = Sheets("May 2010").Cells(1, Columns.Count).End(xlToLeft).Column
  Range(Cells(2, 1), Cells(LR, LC)).Copy Destination:=Sheets("Full Dataset").Range("A1")

 

[MrKowz]

Try:

  Dim LR As Long
  Dim LC As Long
  Dim dLR As Long
  LR = Sheets("May 2010").Range("A" & Rows.Count).End(xlUp).Row
  LC = Sheets("May 2010").Cells(1, Columns.Count).End(xlToLeft).Column
  dLR = Sheets("Full Dataset").Range("A" & Rows.Count).End(xlUp).Row + 1
  Range(Cells(2, 1), Cells(LR, LC)).Copy Destination:=Sheets("Full Dataset").Range("A" & dLR)

 

[Stepheny2k2]

Thanks again,

Unfortunately this didn't work. I can't quite follow why but examining the lines using breakpoints it doesn't seem to do the select so doesn't copy and paste any records.

I am interested in a solution to this because my original is quite long and inefficient, but I should point out that I have since got it working via another solution which fit into my original code. Extract below:

Sheets("May 2010").Select
    Range("A2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    [COLOR=red]If Application.WorksheetFunction.CountA(Selection) > 0 Then[/COLOR]
    Selection.Copy
    Sheets("Therapies Data").Select
    ActiveSheet.Paste
    Range("A281").Select
    Selection.End(xlDown).Select
    [COLOR=red]End If[/COLOR]
    ActiveCell.Offset(1, 0).Select
    ' Copy All data added for June and pastes at position one cell below May's dataset
Sheets("June 2010").Select
    Range("A2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    [COLOR=red]If Application.WorksheetFunction.CountA(Selection) > 0 Then[/COLOR]
    Selection.Copy
    Sheets("Therapies Data").Select
    ActiveSheet.Paste
    Range("A426").Select
    Selection.End(xlDown).Select
    [COLOR=red]End If[/COLOR]
    ActiveCell.Offset(1, 0).Select
    ...
'This code block is repeated for each month in the year

The above solution does make for very long code and could probably benefit from a loop which would apply the same logic to each sheet but it does work.

 

[MrKowz]

Give this a shot:

Public Sub PopulateTherapiesData()
Dim sws     As Worksheet, _
    sLR     As Long, _
    sLC     As Long, _
    dws     As worskheet, _
    dLR     As Long, _
    iMonth  As Long
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With
Set dws = Sheets("Therapies Data")
For i = 1 To 12
    Set sws = Sheets(Format(DateSerial(2010, i, 1), "mmm yyyy"))
    sLR = sws.Range("A" & Rows.Count).End(xlUp).Row
    sLC = sws.Cells(2, Columns.Count).End(xlToLeft).Column
    dLR = dws.Range("A" & Rows.Count).End(xlUp).Row + 1
    If sLR > 2 And sLC > 1 Then
        sws.Range(sws.Cells(2, 1), sws.Cells(sLR, sLC)).Copy Destination:=dws.Range("A" & dLR)
    End If
Next i
With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With
End Sub