Posts by Ger Plante

Cool... that works too

Welcome to the forum BD....

Did you post this question somewhere else?If so please link to the other threads that you have started on other websites

Also, your thread title should describe the problem you are trying to solve and not specify you are in over your head. This helps other people when they are searching for solutions to similar type problems. I have updated the thread title now.

For fast turnaround projects, with guaranteed solutions you should consider the hire help forum here...
https://www.ozgrid.com/forum/forum/hire-help

Anyway, without seeing your workbook and data - then the scenario you described is covered by the following code. It should get you started.

Option Explicit


Public Sub Summarize()


Dim r As Range
Dim r2 As Range
Dim ws As Worksheet
Dim wsSummary As Worksheet
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Summary").Delete: Set wsSummary = Worksheets.Add: wsSummary.Name = "Summary"


For Each ws In ThisWorkbook.Worksheets
    If LCase(ws.Name) <> "summary" Then
        ws.Cells.AutoFilter
        Set r = ws.Range("A1:E50")
        r.AutoFilter 5, ">0"   'filter column 5 for rows > 0
        Set r2 = r.Offset(1, 0).Resize(r.Rows.Count - 1).SpecialCells(xlCellTypeVisible) 'find the filtered rows
        r2.copy wsSummary.Range("A" & Rows.Count).End(xlUp).Offset(1) 'copy the filtered rows
    End If
Next


wsSummary.Range("A1:E1").Value = Worksheets(2).Range("A1:E1").Value 'copy headers into summary


End Sub

if you need further help, please attached a sample workbook. Or go to the hire help section.

Regards
Ger

Hi Paul - does this work?

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
 If ActiveCell.Column = 1 Then
  'David McRitchie,  2007-09-07    insrtrow.htm on double-click
  '-- will copy more often than  Extend Formulas and Format (tools option)
  Cancel = True
  Target.EntireRow.Copy
  Cells(Target.Row + 1, 1).EntireRow.Insert
  Cells(Target.Row + 1, 1).EntireRow.Select
  ActiveSheet.Paste
  Application.CutCopyMode = False
  On Error Resume Next
  '-- customize range for what cells constants can be removed --
  Intersect(Selection, Range("E:IV")).SpecialCells(xlConstants).ClearContents
  Cells(Target.Row, 5).resize(2).Value = 1
  On Error GoTo 0
 Else
End If
End Sub

Just one extra line towards the end of the macro.

Ger

Hi Lisa -welcome to the forum - if you attach your code in a workbook and remove any confidential data then maybe we can help you a little more.

Subscript out of range could be that you are referring to an incorrect worksheet name e.g. Worksheets("Shhet1") would cause a subscript out of range, or if you are referring to an array, you may accidentally refer to an array element that doesnt exist. say there are 100 elements in the array and you referred to array(101), then this would also cause a subscript out of range.

Regards
Ger

Also updated thread title

Hi JL2509, I would be interested in seeing what you came up with for a solution. Please find attached one approach from me. Array Formula:

=IFERROR(INDEX($C$3:$C$15,LARGE((($F$3:$F$15="Contract Owner")+($F$3:$F$15="Main Contractor"))*($G$3:$G$15="Active")*ROW($F$3:$F$15)-2,ROW(1:1))),"")

Regards
Ger

Thanks Pike - that works... its a better option than my multiple if statements, and complicated IIF effort.

To restate the problem - if any of the ranges in a union is nothing then the resulting union is also nothing. So for example.
Union ("A1", "E10") results in a range("A1","10")
Union ("A1", "E10","G20") results in a range("A1","10","G20")
However,
Union ("A1", nothing ,"G20") results in a range = nothing (as opposed to a range with "A1" and "G20").

So in my case, I had to test the ranges before "unioninising" them

its a bit of a limitation on Union that I wasnt aware of... and it kinda sucks if you are doing a union with many ranges.

Ger

You should use the "Databodyrange" method for the listobject to work with the data in the table. Databodyrange will always point to your data excluding your headers. When you combine this with specialcells(xlcelltypevisible) you will see how many cells are hidden or not.

You can also set a range to those visible cells and then set their value to whatever you want... for example:

Option Explicit


Public Sub test()


Dim lo As ListObject
Dim r As Range


Set lo = ActiveSheet.ListObjects(1)
lo.Range.AutoFilter 6, "="


Debug.Print "There are " & lo.DataBodyRange.Rows.Count & " rows in the this listobject"
Debug.Print "There are " & lo.DataBodyRange.Columns(6).SpecialCells(xlCellTypeVisible).Cells.Count & " visible rows being displayed"


Set r = lo.DataBodyRange.Columns(6).SpecialCells(xlCellTypeVisible) 'set a range variable to the visible cells. 


r.Value = "This cell is empty" 'updates all the visible cells in the table with a value. 


End Sub

note - if there are NO blanks in the column 6, the above code will fail, so you should allow the error to occur with "On error resume next" and then trap the error with something like "if not r is nothing then...."

HTH
Ger

I had a problem today where I needed to indentify missing formulas from a column of data. Lets assume the data is in A1:A10.

I thought it was a simple problem using specialcells method to identify constants (i.e. not a formula) and also blanks. This was fine, but I realised quickly that UNION will fail if any of the ranges were "nothing" i.e. the range was missing either a constant or a blank. So below are the three options. The last two worked, but arent ideal.

Option Explicit


Public Sub test()


Dim r1 As Range
Dim r2 As Range
Dim r3 As Range
Dim r4 As Range


On Error Resume Next
Set r1 = Range("$A1:A10")
Set r2 = r1.SpecialCells(xlCellTypeConstants)
Set r3 = r1.SpecialCells(xlCellTypeBlanks)


'create range for both blank cells and constants
Set r4 = Union(r2, r3) 'results in r4 = nothing if either r2 or r3 is nothing,
Debug.Print r4.Address


'this works but it is FUGLY
If r2 Is Nothing Then
    If r3 Is Nothing Then
        Set r4 = Nothing
    Else
        Set r4 = r3
    End If
Else
    If r3 Is Nothing Then
        Set r4 = r2
    Else
        Set r4 = Union(r2, r3)
    End If
End If
Debug.Print r4.Address


'This seems to work... but hard to maintain.
Set r4 = IIf(r2 Is Nothing, IIf(r3 Is Nothing, Nothing, r3), IIf(r3 Is Nothing, r4, Union(r3, r4)))
Debug.Print r4.Address


End Sub

Are there any other simpler suggestions (without loops anyway) to find missing formulas from a column of data.

Regards
Ger

if you have a pbix I will try and take a look too on the PBI desktop

Horse

rajakoli636 - Banned. Completely unacceptable response. KJ has responded 5 times to this thread to give you code and free advice on HIS own time. Learn a little gratitude and decorum. Have a nice day.

Payment Received...:cheers:

:thanx:

So far as I understand the recordset.find method can only take one criteria parameter so I think you are snookered there, but why dont you change SQL statement to include the search criteria... e.g. Select jmapartID, omlPartID from x where jmaPartID = c.value and omlpartID = c.value

Put that SQL in the For each loop

and just rsOra.recordcount on the result.

That could be nonsense of course as I'm after two glasses of wine and my SQL and DAO are super rusty.

Ger

Let me know if this works for you:

[vba]
Sub Multiplier()

Dim dblAnswer As Double
Dim rng As Range
Dim rTemp As Range

Application.ScreenUpdating = False
On Error Resume Next
Set rng = Worksheets("Page1_1").UsedRange.Columns("I").SpecialCells(xlCellTypeConstants, xlNumbers)
If Not rng Is Nothing Then
dblAnswer = CDbl(InputBox("Enter Multiplier for Column I", "Multiplier", 1))
If dblAnswer <> 0 Then
Set rTemp = Worksheets("Page1_1").UsedRange.SpecialCells(xlLastCell).Offset(1, 1)
rTemp = dblAnswer
rTemp.Copy
rng.PasteSpecial xlPasteValues, xlPasteSpecialOperationMultiply
rTemp = ""
Application.CutCopyMode = False
End If
Else
MsgBox "No numbers cells found in Column I"
End If
On Error GoTo 0

Application.ScreenUpdating = True

End Sub
[/vba]

I'll look at this now for you JL

Ger

Got it... slight amendment for me:
Sub Get_The_List_of_Exe_in_memory()

Dim oServ As Object
Dim cProc As Variant
Dim oProc As Object

Set oServ = GetObject("winmgmts:")
Set cProc = oServ.ExecQuery("Select * from Win32_Process")
ActiveSheet.Cells.Clear

For Each oProc In cProc
ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1) = oProc.Name
Next

End Sub

Interesting - however - automation error for me on

Set objWMI

line.

Win 7 / Excel 2016 64 bit.

activity

Hi Aju - I thought GCExcel was working on this project as per post number 2 above?