Posted By

lolrenx on 12/20/12


Tagged

class excel vba Datarange currentregion


Versions (?)

Who likes this?

1 person have marked this snippet as a favorite

lolrenx


Datarange as Class


 / Published in: Visual Basic
 

consider currentregion as a 'datarange' custom class

  1. Option Explicit
  2. Option Compare Text
  3. ' Models a discrete range (select a cell and press Ctrl+A) as a modifiable data table
  4. Private cRange As Range
  5.  
  6. Public Event OccuredBlankRow()
  7.  
  8. Property Set Range(tgtRange As Range)
  9. ' Init with either one cell from the range or the whole preset range
  10. If tgtRange Is Nothing Then Exit Property
  11.  
  12. If tgtRange.Cells.Count = 1 Then
  13. Set cRange = tgtRange.CurrentRegion
  14. Else
  15. Set cRange = tgtRange
  16. End If
  17.  
  18. End Property
  19.  
  20. Property Get Range() As Range
  21.  
  22. 'return full range - inc headers
  23. Set Range = cRange
  24.  
  25. End Property
  26.  
  27. Property Get Range_No_Header() As Range
  28.  
  29. 'return range excluding header (if rowcount >1)
  30. If Me.Range.Rows.Count = 1 Then
  31. Set Range_No_Header = Me.Range
  32. Else
  33. Set Range_No_Header = cRange.Offset(1, 0).Resize(cRange.Rows.Count - 1, cRange.Columns.Count)
  34. End If
  35.  
  36. End Property
  37. Property Get RowCount() As Long
  38. 'count of rows including header
  39. RowCount = cRange.Rows.Count
  40.  
  41. End Property
  42.  
  43. Property Get ColumnsCount() As Long
  44. 'count of columns
  45. ColumnsCount = cRange.Columns.Count
  46.  
  47. End Property
  48.  
  49. Property Get HeaderString(Separator As String) As String
  50. 'apply a 'range to string' to header range with user-defined separator
  51. Dim tCell As Range, tmpString As String
  52.  
  53. For Each tCell In Me.HeaderRange.Cells
  54. tmpString = tmpString & Separator & Trim(tCell.Value)
  55. Next tCell
  56.  
  57. Do Until Right(tmpString, 1) <> Separator
  58. tmpString = Left(tmpString, Len(tmpString) - 1)
  59. Loop
  60. Do Until Left(tmpString, 1) <> Separator
  61. tmpString = Right(tmpString, Len(tmpString) - 1)
  62. Loop
  63.  
  64. HeaderString = tmpString
  65.  
  66. Set tCell = Nothing
  67. tmpString = vbNullString
  68.  
  69. End Property
  70.  
  71. Property Get HeaderRange() As Range
  72.  
  73. If Me.Range Is Nothing Then Exit Property
  74.  
  75. Set HeaderRange = Me.Range.Rows(1)
  76.  
  77. End Property
  78.  
  79. Property Get OmitHeader(Optional ColumnHeader As String) As Range
  80. 'return column without header, or full datarange if no header passed
  81. If cRange Is Nothing Or cRange.Rows.Count < 2 Then Exit Property
  82.  
  83. If Len(ColumnHeader) = 0 Then
  84. With cRange
  85. Set OmitHeader = Me.Range_No_Header
  86. End With
  87. Else
  88. Set OmitHeader = Me.GetColumn(ColumnHeader, True)
  89. End If
  90.  
  91. End Property
  92.  
  93. Property Get Match_Column(tString As String) As Long
  94. 'returns absolute reference to search for a header, works for data in col as well
  95.  
  96. If cRange Is Nothing Or Len(tString) = 0 Then Exit Property
  97.  
  98. Dim i As Long
  99. Dim TempVar As Variant
  100. On Error Resume Next
  101. TempVar = WorksheetFunction.Match(tString, Me.HeaderRange, 0)
  102. On Error GoTo 0
  103. If TempVar > 0 Then
  104. i = 1
  105. Do Until Me.HeaderRange.Cells(i) = tString
  106. i = i + 1
  107. Loop
  108. End If
  109.  
  110. If i > 0 Then
  111. Match_Column = i
  112. End If
  113.  
  114. On Error Resume Next
  115. TempVar = 0
  116. Set TempVar = Nothing
  117. On Error GoTo 0
  118. i = 0
  119.  
  120. End Property
  121.  
  122. Property Get GetColumn(Header As String, Optional OmitHeader As Boolean) As Range
  123.  
  124. If Me.Match_Column(Header) = 0 Then Exit Property
  125.  
  126. Set GetColumn = Me.Range.Columns(Me.Match_Column(Header))
  127.  
  128. If OmitHeader And Not GetColumn Is Nothing Then
  129. If GetColumn.Rows.Count = 1 Then
  130. Exit Property
  131. Else
  132. Set GetColumn = GetColumn.Offset(1, 0).Resize(GetColumn.Rows.Count - 1, GetColumn.Columns.Count)
  133. End If
  134. End If
  135.  
  136. End Property
  137. Property Get First_Cell() As Range
  138.  
  139. Dim tRange As Range: Set tRange = Me.Range
  140.  
  141. Set First_Cell = tRange.Cells(1, 1)
  142.  
  143. Set tRange = Nothing
  144.  
  145. End Property
  146.  
  147. Property Get Last_Cell() As Range
  148.  
  149. Dim tRange As Range: Set tRange = Me.Range
  150. With Me.Range
  151. If WorksheetFunction.CountA(Me.Range) = 0 Or Me.Range.Cells.Count = 1 Then
  152. Set Last_Cell = Me.Range.Cells(1, 1)
  153. Else
  154. Set Last_Cell = Me.Range.Cells(Me.Range.Rows.Count, Me.Range.Columns.Count)
  155. End If
  156. End With
  157.  
  158. Set tRange = Nothing
  159.  
  160. End Property
  161.  
  162. Property Get Value_Lookup(TgtValue As Variant, RefColumnHeader As String, SearchColumnHeader As String) As Variant
  163.  
  164. If Len(RefColumnHeader) = 0 Or Len(SearchColumnHeader) = 0 Then Exit Property
  165.  
  166. On Error Resume Next
  167. Value_Lookup = WorksheetFunction.Match(TgtValue, Me.GetColumn(RefColumnHeader), 0)
  168.  
  169. On Error GoTo 0
  170. If Not IsError(Value_Lookup) And Value_Lookup <> 0 Then
  171. Value_Lookup = Me.GetColumn(SearchColumnHeader).Cells(Value_Lookup, 1)
  172. Else
  173. Value_Lookup = ""
  174. End If
  175.  
  176. End Property
  177.  
  178. Public Sub ClearData(Optional ClearHeaders As Boolean)
  179.  
  180. Call Me.Remove_Blank_Rows
  181.  
  182. If ClearHeaders Then
  183. Me.Range.Clear
  184. Else
  185. Me.Range_No_Header.Clear
  186. End If
  187.  
  188. End Sub
  189.  
  190. Sub Remove_Multiple_Columns(ColHeaders As Variant)
  191.  
  192. If IsMissing(ColHeaders) Then Exit Sub
  193.  
  194. Dim i As Long
  195.  
  196. If IsArray(ColHeaders) Then
  197. For i = LBound(ColHeaders) To UBound(ColHeaders)
  198. Call Me.Remove_Column(CStr(ColHeaders(i)))
  199. Next i
  200. End If
  201. i = 0
  202.  
  203. End Sub
  204.  
  205. Sub Remove_Column(ColHeader As String)
  206.  
  207. If Len(ColHeader) = 0 Then Exit Sub
  208.  
  209. Dim colNum As Long
  210.  
  211. With Me.Range
  212. colNum = MatchCol(ColHeader, .Rows(1))
  213. If colNum <> 0 Then .Columns(colNum).Delete
  214. End With
  215.  
  216. colNum = 0
  217.  
  218. End Sub
  219.  
  220. Sub Add_Column(AfterColHeader As String, NewHeader As String)
  221.  
  222. If Len(AfterColHeader) = 0 Then Exit Sub
  223.  
  224. Dim colNum As Long
  225.  
  226. With Me.Range
  227. colNum = MatchCol(AfterColHeader, .Rows(1))
  228. If colNum <> 0 Then
  229. .Columns(colNum + 1).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
  230. .Cells(1, colNum + 1) = NewHeader
  231. End If
  232. End With
  233.  
  234. colNum = 0
  235.  
  236. End Sub
  237.  
  238. Sub Trim_Values()
  239.  
  240. If Me.Range Is Nothing Then Exit Sub
  241. Dim VrtValues As Variant: VrtValues = Me.Range.Value
  242. Dim i As Long, j As Long
  243. For i = LBound(VrtValues, 1) To UBound(VrtValues, 1)
  244. For j = LBound(VrtValues, 2) To UBound(VrtValues, 2)
  245. VrtValues(i, j) = Trim(VrtValues(i, j))
  246. Next j
  247. Next i
  248. Me.Range.Value = VrtValues
  249.  
  250. Erase VrtValues
  251. i = 0
  252. j = 0
  253.  
  254. End Sub
  255.  
  256. Sub Remove_Number_as_Text(Optional RemoveNumberFormat As Boolean)
  257. With Me.Range.Cells
  258. .Value = .Value
  259. If RemoveNumberFormat Then .NumberFormat = "General"
  260. End With
  261. End Sub
  262.  
  263. Sub Format(Optional NoFill As Boolean, _
  264. Optional ForceVerticalLines As Boolean, Optional NoBold As Boolean, Optional ThickBorder As Boolean)
  265.  
  266. If Me.Range Is Nothing Then Exit Sub
  267. If Me.OmitHeader Is Nothing Then GoTo SingleRow
  268.  
  269. With Me.OmitHeader
  270. .Interior.Pattern = xlPatternNone
  271. .Interior.ThemeColor = xlThemeColorDark1
  272. .Borders(xlDiagonalDown).LineStyle = xlNone
  273. .Borders(xlDiagonalUp).LineStyle = xlNone
  274. .Borders.LineStyle = xlContinuous
  275. .Borders.Weight = xlThin
  276. If ThickBorder Then Me.HeaderRange.Borders.Weight = xlMedium Else .Borders.Weight = xlThin
  277. If Not ForceVerticalLines Then .Borders(xlInsideVertical).LineStyle = xlNone
  278. End With
  279.  
  280. SingleRow:
  281. If Me.HeaderRange Is Nothing Then Exit Sub
  282.  
  283. With Me.HeaderRange
  284. If Not NoFill Then .Interior.ColorIndex = 15
  285. .Interior.ColorIndex = 15
  286. If Not NoBold Then .Font.Bold = True Else .Font.Bold = False
  287. .Borders(xlDiagonalDown).LineStyle = xlNone
  288. .Borders(xlDiagonalUp).LineStyle = xlNone
  289. .Borders.LineStyle = xlContinuous
  290. If ThickBorder Then .Borders.Weight = xlMedium Else .Borders.Weight = xlThin
  291. If Not ForceVerticalLines Then .Borders(xlInsideVertical).LineStyle = xlNone
  292. End With
  293.  
  294. End Sub
  295.  
  296. Sub Apply_Color(ColHeader As String, xColor As Long)
  297.  
  298. Dim tgtRange As Range: Set tgtRange = Me.GetColumn(ColHeader, True)
  299.  
  300. If tgtRange Is Nothing Then Exit Sub
  301.  
  302. tgtRange.Interior.Color = xColor
  303.  
  304. Set tgtRange = Nothing
  305.  
  306. End Sub
  307.  
  308.  
  309. Sub Sort(SortingColumnHeader As String, Optional ForceHeader As Boolean, Optional Reverse As Boolean)
  310.  
  311. If Len(SortingColumnHeader) = 0 Then Exit Sub
  312. Dim tgtCol As Long: tgtCol = MatchCol(SortingColumnHeader, Me.HeaderRange)
  313.  
  314. If tgtCol = 0 Then Exit Sub
  315.  
  316. Call Me.Trim_Values
  317.  
  318. Dim tgtRange As Range: Set tgtRange = Me.Range
  319.  
  320.  
  321. If Not Reverse Then
  322. tgtRange.Sort Key1:=tgtRange.Cells(1, tgtCol), Order1:=xlDescending, Header:=xlYes
  323. 'reset rank to exclude blank rows
  324. Set tgtRange = tgtRange.Cells(1, 1).CurrentRegion
  325. tgtRange.Sort Key1:=tgtRange.Cells(1, tgtCol), Order1:=xlAscending, Header:=xlYes
  326. Else
  327. tgtRange.Sort Key1:=tgtRange.Cells(1, tgtCol), Order1:=xlAscending, Header:=xlYes
  328. Set tgtRange = tgtRange.Cells(1, 1).CurrentRegion
  329. tgtRange.Sort Key1:=tgtRange.Cells(1, tgtCol), Order1:=xlDescending, Header:=xlYes
  330. End If
  331.  
  332. Set cRange = tgtRange.Cells(1, 1)
  333.  
  334. Set tgtRange = Nothing
  335. tgtCol = 0
  336.  
  337. End Sub
  338.  
  339. Sub Remove_Blank_Rows(Optional ForceDelete As Boolean)
  340.  
  341. If Me.Range Is Nothing Or Not Blank_Row_Exists Then Exit Sub
  342.  
  343. Dim KillRange As Range, tCell As Range
  344.  
  345. If ForceDelete Then
  346. For Each tCell In Me.Range.Columns(1).Cells
  347. If WorksheetFunction.CountA(Intersect(tCell.EntireRow, Me.Range)) = 0 Then
  348. If KillRange Is Nothing Then
  349. Set KillRange = Intersect(tCell.EntireRow, Me.Range)
  350. Else
  351. Set KillRange = Union(Intersect(tCell.EntireRow, Me.Range), KillRange)
  352. End If
  353. End If
  354. Next tCell
  355. If Not KillRange Is Nothing Then
  356. KillRange.Delete xlUp
  357. End If
  358. Else
  359. Call Me.Sort(Me.Range.Cells(1, 1), True)
  360. Set cRange = cRange.Cells(1, 1).CurrentRegion
  361. End If
  362.  
  363. Set tCell = Nothing
  364. Set KillRange = Nothing
  365.  
  366. End Sub
  367.  
  368. Sub Delete_if_Different(Header1 As String, Header2 As String, _
  369. Optional DeleteIfSame As Boolean)
  370. 'compares cells in 2 col on the same row, if cells are different then delete row
  371. 'optional if cells are same, delete row
  372.  
  373. Dim tRange As Range: Set tRange = Me.Range
  374. Dim Col1 As Range: Set Col1 = Me.GetColumn(Header1, True)
  375. Dim Col2 As Range: Set Col2 = Me.GetColumn(Header2, True)
  376. Dim i As Long, KillRange As Range
  377. For i = 1 To Col1.Cells.Count
  378. If DeleteIfSame Then
  379. If CStr(Col1.Cells(i).Value) <> CStr(Col2.Cells(i).Value) Then Set KillRange = _
  380. Add_to_Range(Intersect(Me.Range, Col1.Cells(i).EntireRow), KillRange)
  381. Else
  382. If CStr(Col1.Cells(i).Value) = CStr(Col2.Cells(i).Value) Then Set KillRange = _
  383. Add_to_Range(Intersect(Me.Range, Col1.Cells(i).EntireRow), KillRange)
  384. End If
  385. Next i
  386.  
  387. If Not KillRange Is Nothing Then
  388. KillRange.ClearContents
  389. Call Me.Remove_Blank_Rows
  390. End If
  391.  
  392. Set tRange = Nothing
  393. Set KillRange = Nothing
  394. Set Col1 = Nothing
  395. Set Col2 = Nothing
  396. i = 0
  397.  
  398.  
  399. End Sub
  400.  
  401. Sub Delete_Columns(str As Variant)
  402.  
  403. Dim tgtRange As Range: Set tgtRange = Me.Range
  404. If tgtRange Is Nothing Then Exit Sub
  405.  
  406. Dim KillRange As Range, SearchRange As Range, tCell As Range
  407.  
  408. Set SearchRange = Me.HeaderRange
  409.  
  410. If SearchRange Is Nothing Then Exit Sub
  411.  
  412. For Each tCell In SearchRange.Cells
  413. If Value_Exists_in_Range(tCell.Value, str, True) Then
  414. Set KillRange = Add_to_Range(Intersect(tCell.EntireColumn, tgtRange), KillRange)
  415. End If
  416. Next tCell
  417.  
  418. If Not KillRange Is Nothing Then KillRange.Delete
  419.  
  420. Set KillRange = Nothing
  421. Set SearchRange = Nothing
  422. Set tCell = Nothing
  423. Set tgtRange = Nothing
  424.  
  425. End Sub
  426. Sub Keep_Columns(str As Variant)
  427.  
  428. 'Delete any column whose header is not in str
  429. Dim tgtRange As Range: Set tgtRange = Me.Range
  430. If tgtRange Is Nothing Then Exit Sub
  431.  
  432. Dim KillRange As Range, SearchRange As Range, tCell As Range
  433.  
  434. Set SearchRange = Me.HeaderRange
  435.  
  436. If SearchRange Is Nothing Then Exit Sub
  437.  
  438. For Each tCell In SearchRange.Cells
  439. If Not Value_Exists_in_Range(tCell.Value, str, True) Then
  440. Set KillRange = Add_to_Range(Intersect(tCell.EntireColumn, tgtRange), KillRange)
  441. End If
  442. Next tCell
  443.  
  444. If Not KillRange Is Nothing Then KillRange.Delete
  445.  
  446. Set KillRange = Nothing
  447. Set SearchRange = Nothing
  448. Set tCell = Nothing
  449. Set tgtRange = Nothing
  450.  
  451. End Sub
  452.  
  453. Sub Keep_Row_Value(ColHeader As String, str As Variant)
  454.  
  455. Dim tgtRange As Range: Set tgtRange = Me.Range
  456. If tgtRange Is Nothing Then Exit Sub
  457.  
  458. Dim KillRange As Range, SearchRange As Range
  459.  
  460. 'Dim VrtValues As Variant: VrtValues = str
  461.  
  462. Set SearchRange = Me.GetColumn(ColHeader, True)
  463.  
  464. If SearchRange Is Nothing Then Exit Sub
  465.  
  466. Call Me.Trim_Values
  467.  
  468. Dim i As Long, j As Long, vrtSearch As Variant
  469. vrtSearch = SearchRange
  470. For i = LBound(vrtSearch, 1) To UBound(vrtSearch, 1)
  471. If Not Value_Exists_in_Range(CStr(vrtSearch(i, 1)), str, True) Then
  472. Application.StatusBar = "Filtering data in column : (" & ColHeader & ") on tab : " & _
  473. tgtRange.Parent.Name & " based on criteria : " & CStr(vrtSearch(i, 1)) & " - " & _
  474. Calc_Advance(i, UBound(vrtSearch, 1)) & " % done"
  475. Set KillRange = Add_to_Range(Intersect(SearchRange.Cells(i, 1).EntireRow, tgtRange), KillRange)
  476. End If
  477. Next i
  478.  
  479. If Not KillRange Is Nothing Then KillRange.Delete xlUp
  480. Application.StatusBar = False
  481.  
  482. Set KillRange = Nothing
  483. Set SearchRange = Nothing
  484. Set vrtSearch = Nothing
  485. Set tgtRange = Nothing
  486. i = 0
  487. j = 0
  488.  
  489.  
  490. End Sub
  491.  
  492. Sub Delete_Row_Value(ColHeader As String, str As Variant)
  493.  
  494. Dim tgtRange As Range: Set tgtRange = Me.Range
  495.  
  496. If tgtRange Is Nothing Or ColHeader = vbNullString Then Exit Sub
  497.  
  498. Dim KillRange As Range, SearchRange As Range, colNum As Long
  499.  
  500. Set SearchRange = Me.GetColumn(ColHeader, True)
  501. If SearchRange Is Nothing Then Exit Sub
  502.  
  503. Call Me.Trim_Values
  504.  
  505. Dim i As Long, j As Long, vrtSearch As Variant
  506. vrtSearch = SearchRange
  507. For i = LBound(vrtSearch, 1) To UBound(vrtSearch, 1)
  508. If Value_Exists_in_Range(CStr(vrtSearch(i, 1)), str, True) Then
  509. Application.StatusBar = "Filtering data in column : (" & ColHeader & ") on tab : " & _
  510. tgtRange.Parent.Name & " based on criteria : " & CStr(vrtSearch(i, 1)) & " - " & _
  511. Calc_Advance(i, UBound(vrtSearch, 1)) & " % done"
  512. Set KillRange = Add_to_Range(Intersect(SearchRange.Cells(i, 1).EntireRow, tgtRange), KillRange)
  513. End If
  514. Next i
  515.  
  516. If Not KillRange Is Nothing Then KillRange.Delete xlUp
  517. Application.StatusBar = False
  518.  
  519. Set KillRange = Nothing
  520. Set SearchRange = Nothing
  521. Set vrtSearch = Nothing
  522. Set tgtRange = Nothing
  523. i = 0
  524. j = 0
  525.  
  526. End Sub
  527.  
  528. Sub Delete_Rows_With_Filtering(ColHeader As String, vrtValue As Variant, _
  529. Optional ForceNoResort As Boolean)
  530. 'faster for bigger datasets than delete rows
  531.  
  532. If ColHeader = vbNullString Then Exit Sub
  533. Dim tRange As Range: Set tRange = Me.Range
  534. Dim tgtCol As Long: tgtCol = Me.Match_Column(ColHeader)
  535. If tRange.Parent Is Nothing Or tgtCol = 0 Then Exit Sub
  536.  
  537. tRange.Rows(1).EntireRow.Hidden = True
  538.  
  539. On Error Resume Next
  540. tRange.AutoFilter = False
  541. tRange.AutoFilter
  542. On Error GoTo 0
  543.  
  544. tRange.AutoFilter Field:=tgtCol, Criteria1:=vrtValue, Operator:=xlFilterValues
  545.  
  546. On Error Resume Next
  547. tRange.SpecialCells(xlVisible).EntireRow.ClearContents
  548. tRange.AutoFilter = False
  549. tRange.Parent.ShowAllData
  550. On Error GoTo 0
  551.  
  552. tRange.Rows(1).EntireRow.Hidden = False
  553.  
  554. If Not ForceNoResort Then
  555. Call Me.Remove_Blank_Rows
  556. End If
  557.  
  558. Set tRange = Nothing
  559. tgtCol = 0
  560.  
  561. End Sub
  562.  
  563. Sub Expand_Formula(ColHeader As String, FormulaString As String, _
  564. Optional ForceValue As Boolean, Optional IsArrayFormula As Boolean, Optional NoCalc As Boolean)
  565.  
  566. 'use nocalc is several consecutive range to be filled, calc at the end
  567.  
  568. If Len(FormulaString) = 0 Or Len(ColHeader) = 0 Then Exit Sub
  569.  
  570. Dim LastRow As Long: LastRow = Me.Last_Cell.Row
  571. Dim FillRange As Range: Set FillRange = Me.GetColumn(ColHeader, True)
  572.  
  573. If FillRange Is Nothing Then Exit Sub
  574.  
  575. If IsArrayFormula Then
  576. FillRange.Cells(1).FormulaArray = FormulaString
  577. Else
  578. FillRange.Cells(1).Formula = FormulaString
  579. End If
  580.  
  581. FillRange.Cells(1).AutoFill Destination:=FillRange
  582.  
  583. If NoCalc Then ForceValue = False Else FillRange.Calculate
  584.  
  585. If ForceValue Then FillRange.Cells.Value = FillRange.Cells.Value
  586.  
  587. LastRow = 0
  588. Set FillRange = Nothing
  589.  
  590. End Sub
  591.  
  592. Sub Remove_Duplicates(str As Variant)
  593.  
  594. Dim tRange As Range: Set tRange = Me.Range
  595.  
  596. 'remove duplicates in str columns - accepts either single string or strings array
  597. If IsArray(str) Then
  598. Dim TempStr() As Variant, i As Long
  599. ReDim TempStr(0 To UBound(str))
  600. For i = 0 To UBound(TempStr)
  601. If TypeName(str(i)) = "String" Then
  602. TempStr(i) = Me.Match_Column(CStr(str(i)))
  603. ElseIf TypeName(str(i)) = "Integer" Or TypeName(str(i)) = "Long" Then
  604. TempStr(i) = str(i)
  605. End If
  606. Next i
  607. tRange.RemoveDuplicates Columns:=(TempStr), Header:=xlYes
  608. Else
  609. If TypeName(str) = "String" Then
  610. tRange.RemoveDuplicates Columns:=Me.Match_Column(CStr(str)), Header:=xlGuess
  611. ElseIf TypeName(str) = "Integer" Or TypeName(str) = "Long" Then
  612. tRange.RemoveDuplicates Columns:=str, Header:=xlYes
  613. End If
  614. End If
  615.  
  616. Erase TempStr
  617.  
  618. Call Me.Remove_Blank_Rows
  619.  
  620. End Sub
  621.  
  622. Sub Remove_Below(ColHeader As String, Cap As Long, Optional EntireRow As Boolean)
  623. 'delete cells below 'cap' threshold, option to delete entirerow
  624. If Len(ColHeader) = 0 Then Exit Sub
  625.  
  626. Dim tgtRange As Range, tCell As Range, KillRange As Range
  627. Set tgtRange = Me.GetColumn(ColHeader, True)
  628. If tgtRange Is Nothing Then Exit Sub
  629.  
  630. For Each tCell In tgtRange.Cells
  631. If tCell.Value < Cap Then
  632. If EntireRow Then
  633. Set KillRange = Add_to_Range(Intersect(tCell.EntireRow, tCell.CurrentRegion), KillRange)
  634. Else
  635. Set KillRange = Add_to_Range(Range(tCell.Offset(0, -1), tCell), KillRange)
  636. End If
  637. End If
  638. Next tCell
  639.  
  640. If EntireRow Then
  641. If Not KillRange Is Nothing Then KillRange.ClearContents
  642. Else
  643. If Not KillRange Is Nothing Then KillRange.Delete xlUp
  644. End If
  645.  
  646. Call Me.Remove_Blank_Rows
  647.  
  648. End Sub
  649.  
  650. Private Function Value_Exists_in_Range(SearchValue As String, tgtRange As Variant, Optional forVariant As Boolean) As Boolean
  651. Value_Exists_in_Range = False
  652. If Len(SearchValue) = 0 Then Exit Function
  653.  
  654. 'true if value exists in specified range or array
  655. If forVariant Then
  656. If IsArray(tgtRange) Then
  657. Dim i As Long
  658. For i = LBound(tgtRange) To UBound(tgtRange)
  659. If CStr(tgtRange(i)) = SearchValue Then
  660. Value_Exists_in_Range = True
  661. Exit Function
  662. End If
  663. Next i
  664. Else
  665. GoTo SingleCheckValue
  666. End If
  667. ElseIf TypeName(tgtRange) = "Range" Then
  668. If WorksheetFunction.CountIf(tgtRange, SearchValue) > 0 Then Value_Exists_in_Range = True
  669. Else
  670. SingleCheckValue:
  671. If CStr(tgtRange) = SearchValue Then
  672. Value_Exists_in_Range = True
  673. Exit Function
  674. End If
  675. End If
  676.  
  677. End Function
  678.  
  679. Private Function Blank_Row_Exists() As Boolean
  680.  
  681. 'scan upwards from last row looking for empty rows, true if found
  682.  
  683. Blank_Row_Exists = False
  684. Dim tRange As Range: Set tRange = Me.Range
  685.  
  686. Dim i As Long
  687. For i = tRange.Rows.Count To 1 Step -1
  688. If WorksheetFunction.CountA(tRange.Rows(i)) = 0 Then
  689. Blank_Row_Exists = True
  690. Exit For
  691. End If
  692. Next i
  693.  
  694. Set tRange = Nothing
  695.  
  696. End Function

Report this snippet  

You need to login to post a comment.