this is how my entire macro currently looks... it is not currently deleting
the data out of the cells where the ranges specified are blank...
i can't quite suss out where i'm going wrong...
Sub FamilyPlanningDatabasePrep()
'
' FamilyPlanningDatabasePrep Macro
' Prepares FP return for import into sexual health database - this macro
creates a file labled IMPORT on your desktop
'
'
MsgBox ("This macro formats the FP activity sheet so it can be imported
into the Family Planning & Sexual Health Database" & vbNewLine & vbNewLine &
"The file created is titled 'IMPORT' and can be found in your c:\ drive" &
vbNewLine & vbNewLine & "Once complete, open Family Planning & Sexual Health
Database and follow instructions to import data")
Range("C1:E1,H1:I1,H34:I34,C34:E34").Select
Range("C34").Activate
With Selection
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("C4:C33,G4:G33,M34,M1").Select
Range("M1").Activate
ActiveWindow.SmallScroll Down:=33
Range("C4:C33,G4:G33,M34,M1,C37:C66,G37:G66").Sele ct
Range("G37").Activate
Selection.Replace what:=".", Replacement:="/", lookat:=xlPart, _
searchorder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
ActiveWindow.SmallScroll Down:=-42
Range("A3").Select
ActiveCell.FormulaR1C1 = "attendanceTIME"
With ActiveCell.Characters(Start:=1, Length:=14).Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("B3").Select
ActiveCell.FormulaR1C1 = "patientID"
With ActiveCell.Characters(Start:=1, Length:=9).Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("C3").Select
ActiveCell.FormulaR1C1 = "patientDOB"
With ActiveCell.Characters(Start:=1, Length:=10).Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("D3").Select
ActiveCell.FormulaR1C1 = "patientSEX"
With ActiveCell.Characters(Start:=1, Length:=10).Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("E3").Select
ActiveCell.FormulaR1C1 = "patientCOUNTY"
With ActiveCell.Characters(Start:=1, Length:=13).Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("F3").Select
ActiveCell.FormulaR1C1 = "patientSOURCE"
With ActiveCell.Characters(Start:=1, Length:=13).Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("G3").Select
ActiveCell.FormulaR1C1 = "DATEreferral/prevatt"
With ActiveCell.Characters(Start:=1, Length:=20).Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("H3").Select
ActiveCell.FormulaR1C1 = "referralSOURCE"
With ActiveCell.Characters(Start:=1, Length:=14).Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("I3").Select
ActiveCell.FormulaR1C1 = "attendanceOUTCOME"
With ActiveCell.Characters(Start:=1, Length:=17).Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("J3").Select
ActiveCell.FormulaR1C1 = "attendanceREASON 1"
With ActiveCell.Characters(Start:=1, Length:=18).Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("K3").Select
ActiveCell.FormulaR1C1 = "attendanceREASON 2"
With ActiveCell.Characters(Start:=1, Length:=18).Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("L3").Select
ActiveCell.FormulaR1C1 = "attendanceMETHOD 1"
With ActiveCell.Characters(Start:=1, Length:=18).Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("M3").Select
ActiveCell.FormulaR1C1 = "attendanceMETHOD 2"
With ActiveCell.Characters(Start:=1, Length:=18).Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("N3").Select
ActiveCell.FormulaR1C1 = "attendanceLOCATION"
Range("O3").Select
ActiveCell.FormulaR1C1 = "attendanceDATE"
Range("P3").Select
ActiveCell.FormulaR1C1 = "clinicTYPE"
Range("H1").Select
Selection.Copy
Range("N4:N33").Select
ActiveSheet.Paste
Range("M1").Select
Application.CutCopyMode = False
Selection.Copy
Range("O4:O33").Select
ActiveSheet.Paste
Range("C1").Select
Application.CutCopyMode = False
Selection.Copy
Range("P4:P33").Select
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=33
Range("H34").Select
Application.CutCopyMode = False
Selection.Copy
Range("N37:N66").Select
ActiveSheet.Paste
Range("M34").Select
Application.CutCopyMode = False
Selection.Copy
Range("O37:O66").Select
ActiveSheet.Paste
Range("C34").Select
Application.CutCopyMode = False
Selection.Copy
Range("P37:P66").Select
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=-21
Rows("34:36").Select
Range("A36").Activate
ActiveWindow.SmallScroll Down:=-27
Range("34:36,1:2").Select
Range("A2").Activate
Application.CutCopyMode = False
Selection.Delete shift:=xlUp
Range("I14").Select
Application.DisplayAlerts = False
Sheets("Lookup tables").Select
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
DeleteBlankRows ScanRange:=Range("A4:M4")
DeleteBlankRows ScanRange:=Range("A5:M5")
DeleteBlankRows ScanRange:=Range("A6:M6")
DeleteBlankRows ScanRange:=Range("A7:M7")
DeleteBlankRows ScanRange:=Range("A8:M8")
DeleteBlankRows ScanRange:=Range("A9:M9")
DeleteBlankRows ScanRange:=Range("A10:M10")
DeleteBlankRows ScanRange:=Range("A11:M11")
DeleteBlankRows ScanRange:=Range("A12:M12")
DeleteBlankRows ScanRange:=Range("A13:M13")
DeleteBlankRows ScanRange:=Range("A14:M14")
DeleteBlankRows ScanRange:=Range("A15:M15")
DeleteBlankRows ScanRange:=Range("A16:M16")
DeleteBlankRows ScanRange:=Range("A17:M17")
DeleteBlankRows ScanRange:=Range("A18:M18")
DeleteBlankRows ScanRange:=Range("A19:M19")
DeleteBlankRows ScanRange:=Range("A20:M20")
DeleteBlankRows ScanRange:=Range("A21:M21")
DeleteBlankRows ScanRange:=Range("A22:M22")
DeleteBlankRows ScanRange:=Range("A23:M23")
DeleteBlankRows ScanRange:=Range("A24:M24")
DeleteBlankRows ScanRange:=Range("A25:M25")
DeleteBlankRows ScanRange:=Range("A26:M26")
DeleteBlankRows ScanRange:=Range("A27:M27")
DeleteBlankRows ScanRange:=Range("A28:M28")
DeleteBlankRows ScanRange:=Range("A29:M29")
DeleteBlankRows ScanRange:=Range("A30:M30")
DeleteBlankRows ScanRange:=Range("A31:M31")
DeleteBlankRows ScanRange:=Range("A32:M32")
DeleteBlankRows ScanRange:=Range("A33:M33")
DeleteBlankRows ScanRange:=Range("A34:M34")
DeleteBlankRows ScanRange:=Range("A35:M35")
DeleteBlankRows ScanRange:=Range("A36:M36")
DeleteBlankRows ScanRange:=Range("A37:M37")
DeleteBlankRows ScanRange:=Range("A38:M38")
DeleteBlankRows ScanRange:=Range("A39:M39")
DeleteBlankRows ScanRange:=Range("A40:M40")
DeleteBlankRows ScanRange:=Range("A41:M41")
DeleteBlankRows ScanRange:=Range("A42:M42")
DeleteBlankRows ScanRange:=Range("A43:M43")
DeleteBlankRows ScanRange:=Range("A44:M44")
DeleteBlankRows ScanRange:=Range("A45:M45")
DeleteBlankRows ScanRange:=Range("A46:M46")
DeleteBlankRows ScanRange:=Range("A47:M47")
DeleteBlankRows ScanRange:=Range("A48:M48")
DeleteBlankRows ScanRange:=Range("A49:M49")
DeleteBlankRows ScanRange:=Range("A50:M50")
DeleteBlankRows ScanRange:=Range("A51:M51")
DeleteBlankRows ScanRange:=Range("A52:M52")
DeleteBlankRows ScanRange:=Range("A53:M53")
DeleteBlankRows ScanRange:=Range("A54:M54")
DeleteBlankRows ScanRange:=Range("A55:M55")
DeleteBlankRows ScanRange:=Range("A56:M56")
DeleteBlankRows ScanRange:=Range("A57:M57")
DeleteBlankRows ScanRange:=Range("A58:M58")
DeleteBlankRows ScanRange:=Range("A59:M59")
DeleteBlankRows ScanRange:=Range("A60:M60")
DeleteBlankRows ScanRange:=Range("A61:M61")
DeleteBlankRows ScanRange:=Range("A62:M62")
DeleteBlankRows ScanRange:=Range("A63:M63")
DeleteBlankRows ScanRange:=Range("A64:M64")
DeleteBlankRows ScanRange:=Range("A65:M65")
DeleteBlankRows ScanRange:=Range("A66:M66")
ChDir "C:\"
ActiveWorkbook.SaveAs Filename:= _
"C:\IMPORT.xls", FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
MsgBox ("Remember to delete all empty lines from table" & vbNewLine
& vbNewLine & "Once complete, select 'SAVE'" & vbNewLine & vbNewLine & "A
file will be generated in your c:\ drive titled 'IMPORT'" & vbNewLine &
vbNewLine & "Import into Family Planning Database")
End Sub
Sub DeleteBlankRows(ScanRange As Range, Optional WorksheetName As Variant)
'''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''
' DeleteBlankRows
' This function will delete all blank rows on the worksheet
' named by WorksheetName. This will delete rows that are
' completely blank (every cell = vbNullString) or that have
' cells that contain only an apostrophe (special Text control
' character).
' The code will look at each cell that contains a formula,
' then look at the precedents of that formula, and will not
' delete rows that are a precedent to a formula. This will
' prevent deleting precedents of a formula where those
' precedents are in lower numbered rows than the formula
' (e.g., formula in A10 references A1:A5). If a formula
' references cell that are below (higher row number) the
' last used row (e.g, formula in A10 reference A20:A30 and
' last used row is A15), the refences in the formula will
' be changed due to the deletion of rows above the formula.
'
'''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''
Dim RefColl As Collection
Dim RowNum As Long
Dim Prec As Range
Dim Rng As Range
Dim DeleteRange As Range
Dim LastRow As Long
Dim FormulaCells As Range
Dim Test As Long
Dim WS As Worksheet
Dim PrecCell As Range
If IsMissing(WorksheetName) = True Then
Set WS = ActiveSheet
Else
On Error Resume Next
Set WS = ActiveWorkbook.Worksheets(WorksheetName)
If Err.Number < 0 Then
'''''''''''''''''''''''''''''''
' Invalid worksheet name.
'''''''''''''''''''''''''''''''
Exit Sub
End If
End If
If Application.WorksheetFunction.CountA(WS.UsedRange. Cells) = 0 Then
''''''''''''''''''''''''''''''
' Worksheet is blank. Get Out.
''''''''''''''''''''''''''''''
Exit Sub
End If
''''''''''''''''''''''''''''''''''''''
' Find the last used cell on the
' worksheet.
''''''''''''''''''''''''''''''''''''''
Dim FirstRow As Long
LastRow = ScanRange.Cells(ScanRange.Cells.Count).Row
FirstRow = ScanRange(1, 1).Row
Set RefColl = New Collection
'''''''''''''''''''''''''''''''''''''
' We go from bottom to top to keep
' the references intact, preventing
' #REF errors.
'''''''''''''''''''''''''''''''''''''
For RowNum = LastRow To FirstRow Step -1
Set FormulaCells = Nothing
If Application.WorksheetFunction.CountA(WS.Rows(RowNu m)) = 0 Then
''''''''''''''''''''''''''''''''''''
' There are no non-blank cells in
' row R. See if R is in the RefColl
' reference Collection. If not,
' add row R to the DeleteRange.
''''''''''''''''''''''''''''''''''''
On Error Resume Next
Test = RefColl(CStr(RowNum))
If Err.Number < 0 Then
''''''''''''''''''''''''''
' R is not in the RefColl
' collection. Add it to
' the DeleteRange variable.
''''''''''''''''''''''''''
If DeleteRange Is Nothing Then
Set DeleteRange = WS.Rows(RowNum)
Else
Set DeleteRange = Application.Union(DeleteRange,
WS.Rows(RowNum))
End If
Else
''''''''''''''''''''''''''
' R is in the collection.
' Do nothing.
''''''''''''''''''''''''''
End If
On Error GoTo 0
Err.Clear
Else
'''''''''''''''''''''''''''''''''''''
' CountA 0. Find the cells
' containing formula, and for
' each cell with a formula, find
' its precedents. Add the row number
' of each precedent to the RefColl
' collection.
'''''''''''''''''''''''''''''''''''''
If IsRowClear(RowNum:=RowNum) = True Then
'''''''''''''''''''''''''''''''''
' Row contains nothing but blank
' cells or cells with only an
' apostrophe. Cells that contain
' only an apostrophe are counted
' by CountA, so we use IsRowClear
' to test for only apostrophes.
' Test if this row is in the
' RefColl collection. If it is
' not in the collection, add it
' to the DeleteRange.
'''''''''''''''''''''''''''''''''
On Error Resume Next
Test = RefColl(CStr(RowNum))
If Err.Number = 0 Then
''''''''''''''''''''''''''''''''''''''
' Row exists in RefColl. That means
' a formula is referencing this row.
' Do not delete the row.
''''''''''''''''''''''''''''''''''''''
Else
If DeleteRange Is Nothing Then
Set DeleteRange = WS.Rows(RowNum)
Else
Set DeleteRange = Application.Union(DeleteRange,
WS.Rows(RowNum))
End If
End If
Else
On Error Resume Next
Set FormulaCells = Nothing
Set FormulaCells =
WS.Rows(RowNum).SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If FormulaCells Is Nothing Then
'''''''''''''''''''''''''
' No formulas found. Do
' nothing.
'''''''''''''''''''''''''
Else
'''''''''''''''''''''''''''''''''''''''''''''''''' '
' Formulas found. Loop through the formula
' cells, and for each cell, find its precedents
' and add the row number of each precedent cell
' to the RefColl collection.
'''''''''''''''''''''''''''''''''''''''''''''''''' '
On Error Resume Next
For Each Rng In FormulaCells.Cells
For Each Prec In Rng.Precedents.Cells
RefColl.Add Item:=Prec.Row, key:=CStr(Prec.Row)
Next Prec
Next Rng
On Error GoTo 0
End If
End If
End If
'''''''''''''''''''''''''
' Go to the next row,
' moving upwards.
'''''''''''''''''''''''''
Next RowNum
''''''''''''''''''''''''''''''''''''''''''
' If we have rows to delete, delete them.
''''''''''''''''''''''''''''''''''''''''''
If Not DeleteRange Is Nothing Then
DeleteRange.EntireRow.Delete shift:=xlShiftUp
End If
End Sub
Function IsRowClear(RowNum As Long) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''
' IsRowClear
' This procedure returns True if all the cells
' in the row specified by RowNum as empty or
' contains only a "'" character. It returns False
' if the row contains only data or formulas.
''''''''''''''''''''''''''''''''''''''''''''''''''
Dim ColNdx As Long
Dim Rng As Range
ColNdx = 1
Set Rng = Cells(RowNum, ColNdx)
Do Until ColNdx = Columns.Count
If (Rng.HasFormula = True) Or (Rng.Value < vbNullString) Then
IsRowClear = False
Exit Function
End If
Set Rng = Cells(RowNum, ColNdx).End(xlToRight)
ColNdx = Rng.Column
Loop
IsRowClear = True
End Function
"DavidHawes" wrote:
Should i enter the code from http://www.cpearson.com/excel/deleting.htm in
the same macro as the....
DeleteBlankRows ScanRange:=Range("A1:A100")
... function or should this be the code from
http://www.cpearson.com/excel/deleting.htm be set up elsewhere? (eg. as a
module?)
Thanks,
David
"Chip Pearson" wrote:
You can adapt the DeleteBlankRows code on
http://www.cpearson.com/excel/deleting.htm to your needs. Specifically,
'---------------------------
Change
'---------------------------
Sub DeleteBlankRows(Optional WorksheetName As Variant)
' To
Sub DeleteBlankRows(ScanRange As Range, Optional WorksheetName As Variant)
'---------------------------
Delete
'---------------------------
Set Rng = WS.Cells.Find(what:="*", after:=WS.Cells(WS.Rows.Count,
WS.Columns.Count), lookat:=xlPart, _
searchorder:=xlByColumns, searchdirection:=xlPrevious, MatchCase:=False)
'------------------------
Add:
'------------------------
Dim FirstRow As Long
'------------------------
Change
'------------------------
LastRow = Rng.Row
' To
LastRow = ScanRange.Cells(ScanRange.Cells.Count).Row
FirstRow = ScanRange(1, 1).Row
'------------------------
Change
'------------------------
For RowNum = LastRow To 1 Step -1
' To
For RowNum = LastRow To FirstRow Step -1
You can then call this code with a procedure call like
Sub DoDelete()
DeleteBlankRows ScanRange:=Range("A1:A100")
End Sub
--
Cordially,
Chip Pearson
Microsoft MVP - Excel
Pearson Software Consulting, LLC
www.cpearson.com
(email address is on the web site)
"DavidHawes" wrote in message
...
Just wanted to move this up the forums as my subsequent question (below)
would be lost otherwise...
---------------------
As an extra, if I wanted to specify a range of cells that, if blank, would
result in the deletion of the rows where those cells lie, how would I do
this?
Thanks again.
David
"Gord Dibben" wrote:
David
Try this macro to delete just empty rows.
Sub DeleteEmptyRows()
''only if entire row is blank
LastRow = ActiveSheet.UsedRange.Row - 1 + _
ActiveSheet.UsedRange.Rows.Count
Application.ScreenUpdating = False
For r = LastRow To 1 Step -1
If Application.CountA(Rows(r)) = 0 Then
Rows(r).Delete
End If
Next r
End Sub
Gord Dibben MS Excel MVP
On Fri, 23 Feb 2007 05:33:29 -0800, DavidHawes
wrote:
Hi,
I've set up a macro which re-organises an excel spreadsheet into a
format
that enables me to import the data contained within it directly into an
Access database i've set up.
This works perfectly.
However, I want the macro to delete out any lines of my table (which is
fixed in size) that do not contain any data.
Is this possible? If so, can someone please explain what code I need to
enter to get my macro to do this?
Many thanks,
David :-)