rrscils598f08

Which Is Faster And More Efficient - For Loop, Match, Find, Etc?

rrscils598f08@gmail.com (Mitchell Kassulke) — Sun, 01 Oct 2023 06:09:00 +0000

What I am doing is search some strings one by one in the entire range - like search for 'blah1', if found then exit, else search 'blah2' in the entire range in the same manner. 'b

Solution 1:

Try this one. Since your code is repeated (for "blah1" and "blah2") I used additional function:

Sub test()
    If Sheet1.Cells(1, "B") = ""ThenIf findString("blah1") ThenExitSubIf findString("blah2") ThenExitSubEndIfEndSub'Function findString returns TRUE if something found and FALSE otherwiseFunction findString(searchString AsString) AsBooleanDim rng As Range, res

    With Sheet1
        Set rng = .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)

        res = Application.Match(searchString, rng, 0)
        'Application.Match returns error if nothing found
        findString = Not IsError(res)
        If findString Then
            .Cells(1, "B").Value = rng.Cells(res, 1).Row
            .Cells(1, "C").Value = searchString
        EndIfEndWithEndFunction

Solution 2:

I'm reasonably new to Excel Vba, but my limited understanding is that reading from cells is relatively slow. If I were doing this I would read all the values into an array, and carry out the same for loop as you have used, but on the array, rather than cell values.

To confirm, you could use VBAs Timer function to check speed.

Let me know if you'd like more detailed explanations of how to do this.

Solution 3:

Here's how you can turn a range into an array (and vice versa). Step through this code with the Locals window turned on and watch what happens. You are particularly interested in the astrArray variable.

Sub ChangeArray()
'
    Dim astrArray As Variant
'
'   Dim astrArray
'       that is, with no type specified
'       is exactly equivalent
'
    Dim lngIndex As Long
    Dim strMessage As String
'
    Range("A1").Value = "This"
    Range("A2").Value = "is"
    Range("A3").Value = "only"
    Range("A4").Value = "a"
    Range("A5").Value = "test"
    astrArray = Range("A1:A5")
    For lngIndex = 1 To 5
        strMessage = strMessage & astrArray(lngIndex, 1) & " "
        Select Case lngIndex
            Case 1
                astrArray(lngIndex, 1) = "No,"
            Case 2
                astrArray(lngIndex, 1) = "it's"
            Case 3
                astrArray(lngIndex, 1) = "actually"
            Case 4
                astrArray(lngIndex, 1) = "real"
            Case 5
                astrArray(lngIndex, 1) = "life"End Select
    Next lngIndex
    MsgBox strMessage
    Range("A1:A5") = astrArray
End Sub

A key requirement: to do this, the variable must be DIMmed Variant!

Another thing to pay attention to: the variable is two-dimensional, even though the range selected is one-dimensional.

Count Cells With Values In A Column Up To Two Above The Active Cell, Excluding The Header

rrscils598f08@gmail.com (Mitchell Kassulke) — Sat, 30 Sep 2023 23:44:00 +0000

I'm trying to count all the cells in a column that have values above the active cell excluding the header and excluding the cell immediately above the active cell. For example if I

Solution 1:

Try this:

Sub counter()

Dim col AsIntegerDim lastrow AsIntegerDim cellcount AsIntegerWith ActiveCell
    col = .Column
    lastrow = .Row - 2EndWith

cellcount = 0ForEach cell In ActiveSheet.Range(Cells(2, col), Cells(lastrow, col))

    If IsError(cell) ThenGoTo skipcell

    If cell.Value > 0And IsNumeric(cell) Then cellcount = cellcount + 1skipcell:Next cell

ActiveCell = cellcount

EndSub

It takes the active cell and finds the selected colum and find the cell two above the active cell.

It then loops though the range adding to a counter each time it finds a value higher than "0"

As requested by OP in comments added in checks to ensure date in the cell is Numeric and that there is not a error (#N/A) value in the cell

Also requested is for this to span 260 columns in the same row. For this, use of a for loop is employed:

Sub counter()

Dim firstCol asIntegerdim lastCol asInteger

firstCol = 1'You can change this value depending on your first column' for example you might use ActiveCell.Column

lastCol = firstCol + 260Dim col AsIntegerDim lastrow AsInteger
lastRow = 6' Make this the actual last row of the data to includeDim cellcount AsIntegerfor col = firstCol to lastCol

    cellcount = 0ForEach cell In ActiveSheet.Range(Cells(2, col), Cells(lastrow, col))

        If IsError(cell) ThenGoTo skipcell

        If cell.Value > 0And IsNumeric(cell) Then cellcount = cellcount + 1

    skipcell:

    Next cell

    ActiveSheet.Cells(lastRow + 2, col) = cellcount

Next col

EndSub

Solution 2:

Why does this have to be VBA code?

It is very simple to do in a cell formula:

=COUNTIF(A1:A5,"<>0")-2

This counts all the cells in the given range (A1:A5) which are not equal to zero. Since you know you want to remove the header row and one row above, subtract 2 from the answer. Of course, this the same as

=COUNTIF(A2:A4,"<>0")

If you want to use this in VBA then look into WorksheetFunction:

Dim myCount AsInteger
myCount = WorksheetFunction.COUNTIF(ActiveSheet.Range("A2:A4"),"<>0")

Then insert myCount into the sheet

ActiveSheet.Range("A6").value = myCount

Check Merged Cell And Compare Adjacent To Set Unique Value From Compared Cells Values

rrscils598f08@gmail.com (Mitchell Kassulke) — Sat, 30 Sep 2023 23:09:00 +0000

I'm writing a macro in Excel 2010 for a problem that is as follows: I have two columns, one with a Key string value and one with a uuid. The idea is that every key should have onl

Solution 1:

OptionExplicitSub CopyUUID()

    Const UUID AsLong = 31'col AEDim lRow AsLong, cel As Range, isM AsBoolean, copyID AsBoolean, kCol AsLongWith ActiveSheet
        kCol = -25'col F
        lRow = .Cells(.Rows.Count, UUID + kCol).End(xlUp).Row

        ForEach cel In .Range(.Cells(3, UUID), .Cells(lRow, UUID))

            isM = cel.Offset(0, kCol).MergeCells
            copyID = isM And Len(cel.Offset(0, kCol)) = 0
            copyID = copyID Or (Not isM And cel.Offset(0, kCol) = cel.Offset(-1, kCol))

            If copyID Then cel = cel.Offset(-1)
        NextEndWithEndSub

Solution 2:

Try the following code. Note that this is going to overwrite the current contents of UUID, so make a backup copy before testing. If you don't want the UUID column modified, you can modify this to suit your needs.

Sub CopyUUID()
    Dim lRow As Long
    Dim rng AsRange
    Dim c AsRange
    Dim ws As Worksheet
    Dim rMerged AsRange
    Dim valueAs Variant

    Set ws = Sheets(ActiveSheet.Name)

    On Error GoTo ExitProgram 'If an error happens within the execution, skips it and continue in next step
    ' Application.DisplayAlerts =False'We can cancel the procedure without errors

    With ws
        lRow = .Range("F" & .Rows.Count).End(xlUp).Row
        Set rng = .Range(.Cells(3, 6), .Cells(lRow, 6))
        ' rng.Select
        ForEach c In rng

            If c.MergeCells Then'Code for merged cells
                c.Offset(0, 1).Formula = c.MergeArea.Cells(1, 1).Offset(0, 1).Formula
            Else
                'Code to use for single cells
                If c.Formula = c.Offset(-1, 0).Formula Then
                    c.Offset(0, 1).Formula = c.Offset(-1, 1).Formula
                End If
            End If
        Next c
    EndWith
    ExitProgram:
       Exit Sub
End Sub

When in a MergedCell, it makes the UUID the same as the UUID of the first cell in the merged area. When not in a MergedCell, it copies UUID from the row above if Key is the same as the row above.

I changed your variable cell to c (I don't like to use variable names that can be confused with built-ins) and commented out a couple of lines.

Hope this helps

Solution 3:

I adopt a simple approach to this problem as illustrated through steps taken by me.

sample sheet showing data with merged cells and unmerged cells.
Run the program code to unmerge the cells. Output of the program is appended below.

If this structure of data matches your case then addition of 2 lines of code for column B will leave the data as per following image.

Program code is as follows:

'Without column deletion:

Sub UnMergeRanges()
    Dim cl AsRange
    Dim rMerged AsRange
    Dim v As Variant

    ForEach cl In ActiveSheet.UsedRange
        If cl.MergeCells ThenSet rMerged = cl.MergeArea
            v = rMerged.Cells(1, 1)
            rMerged.MergeCells =False
            rMerged = v
        End If
    Next
End Sub
'With coumn deletion   
Sub UnMergeRangesB()
    Dim cl As Range
    Dim rMerged As Range
    Dim v As Variant

    For Each cl In ActiveSheet.UsedRange
        If cl.MergeCells Then
            Set rMerged = cl.MergeArea
            v = rMerged.Cells(1, 1)
            rMerged.MergeCells = False
            rMerged = v
        End If
    Next
    Columns("B:B").Select
    Selection.Delete Shift:=xlToLeft
End Sub

What's The Best Way To Compare Two Sheets In An Excel Workbook

rrscils598f08@gmail.com (Mitchell Kassulke) — Sat, 30 Sep 2023 22:31:00 +0000

Given I have the following Item QTY A 5 B 1 C 3 Item QTY A 15 B 4 C 1 D 8 What is the best

Solution 1:

You shouldn't need VBA for this.

Here's what you do:

Create a new worksheet (Sheet3).
Set it up to look like this:
alt text http://img16.imageshack.us/img16/2451/consolidationsheet.jpg

Here are the formulas you will need (paste each one into the proper cell):

Note: the first two are "array formulas" -- after you paste in the formula, double-click the cell and do Ctrl-Shift-Enter (braces {} should appear around the formula)

------------------------------------------------------------------------------
Cell Formula
------------------------------------------------------------------------------
 B2  =SUM(IF(Sheet1!A:A="",0,1)) <-- array formula: use Ctrl-Shift-Enter instead of Enter
 B3  =SUM(IF(Sheet2!A:A="",0,1)) <-- array formula: use Ctrl-Shift-Enter instead of Enter            
 D2  =IF(D1=D$1,2,IF(OR(D1=B$2,D1=""),"",D1+1))
 E2  =IF(D2="",IF(D1="",IF(OR(E1=B$3,E1=""),"",E1+1),2),"")
 G2  =IF(D2<>"",INDEX(Sheet1!A:A,D2),IF(E2<>"",INDEX(Sheet2!A:A,E2),""))
 H2  =IF(D2<>"",-INDEX(Sheet1!B:B,D2),IF(E2<>"",INDEX(Sheet2!B:B,E2),""))

Drag the formulas in D2:H2 down as far as you need to cover all the data for sheets 1 and 2.
Select all the data in columns G & H (including the headings).
Do Insert > PivotTable and click OK.
Click the Pivot Table and drag []Item to the Row Labels box and []QTY to the Values box.

That's it. The Pivot Table will contain a summary for each item. No item will be repeated, and no item will be left out. The "Sum of QTY" column will actually contain the difference (since the formula uses negative for all sheet 1 quantities).

Solution 2:

In Excel VBA, use a Dictionary. Use your items from one of the sheets as keys, QTY as values. Put the item/QTY pairs of sheet 1 into the dictionary, then run through the items of sheet 2 update the dictionary accordingly to get the differences in there. Finally, put the result into sheet 3.

EDIT: here is a complete example in code (you have to set a reference to the Microsoft Scripting runtime to get it working this way):

OptionExplicitSub CreateDiff()

    Dim dict AsNew Dictionary
    Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
    Dim i AsLong, v AsStringSet sh1 = ThisWorkbook.Sheets("Sheet1")
    Set sh2 = ThisWorkbook.Sheets("Sheet2")
    Set sh3 = ThisWorkbook.Sheets("Sheet3")
    For i = 2To sh1.Cells.SpecialCells(xlCellTypeLastCell).Row
        v = Trim(sh1.Cells(i, 1).Value)
        dict(v) = -sh1.Cells(i, 2).Value
    NextFor i = 2To sh2.Cells.SpecialCells(xlCellTypeLastCell).Row
        v = Trim(sh2.Cells(i, 1).Value)
        If dict.Exists(v) Then
            dict(v) = dict(v) + sh2.Cells(i, 2).Value
        Else
            dict(v) = sh2.Cells(i, 2).Value
        EndIfNextFor i = 0To dict.Count - 1
        v = dict.Keys(i)
        sh3.Cells(i + 2, 1) = v
        sh3.Cells(i + 2, 2) = dict(v)
    NextEndSub

Solution 3:

you could merge both sets of data onto a single sheet side-by-side (item1, qty, item2, qty) then use the VLOOKUP() excel function to find the data from the opposite set.

Solution 4:

One possibility is to use ADO

Dim cn AsObjectDim rs AsObjectDim strFile AsStringDim strCon AsStringDim strSQL AsString''http://support.microsoft.com/kb/246335

strFile = Workbooks("Book1.xls").FullName

''Note HDR=Yes, the names in the first row of the range''can be used.
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile _
    & ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")

cn.Open strCon

strSQL = "SELECT s2.Item, s2.Qty-IIf(s1.Qty Is Null,0,s1.Qty) FROM [Sheet2$] s2 " _
& "LEFT JOIN [Sheet1$] s1 ON s2.Item=s1.Item"

rs.Open strSQL, cn, 3, 3

Workbooks("Book1.xls").Worksheets("Sheet3").Cells(2, 1).CopyFromRecordset rs

Solution 5:

Why use VBA? On Sheet 3 comparison sheet list all possible items from sheets 1 and 2 in column A then in Column B use the following formula. Starting in B2 then copy down.

=if(iserror(vlookup(A2,Sheet2'$A$2:$B$5,2,false),0,vlookup(A2,Sheet2'$A$2:$B$5,2,false))-if(iserror(vlookup(A2,Sheet1'$A$2:$B$5,2,false),0,vlookup(A2,Sheet1'$A$2:$B$5,2,false))

Change the table range as necessary.

Is It Possible To Mimic Excel Rows In A Different Sheet?

rrscils598f08@gmail.com (Mitchell Kassulke) — Sat, 30 Sep 2023 21:46:00 +0000

So in 'Sheet 1' I have 2000 rows of information which I add a new column to every day, I want to have only a subset of the rows of 'Sheet 1' in 'Sheet 2' which update themselves as

Solution 1:

If you want to select a set of particular rows and you know their row numbers, put their row numbers (1,5,8,11,12 ...) in a separate 1 column range and name this range e.g. "RowNumbers"

Then use following normal non-array formula which you can drag downwards and rightwards.

= IF(INDEX(RowNumbers,ROW(A1)+1)>0, INDEX(NamedRange,INDEX(RowNumbers,ROW(A1)+1),COLUMN(B1)+1),"")

You will probably need to adjust the +1 parts, depending on whether your values start at row 1 or 2 etc.

Basically the Excel INDEX formula does what you need - copies the value from another sheet or range by given row and column numbers.

Otherwise you can use following array formula (Ctrl+Shift+Enter) to select filtered values from columns based on multiple criteria:

= IFERROR(INDEX(NamedRange,
   SMALL(IF((INDEX(NamedRange,,1,1)=1)*(INDEX(NamedRange,,2,1)="A"),
   ROW(NamedRange)-MIN(ROW(NamedRange))+1,""),
   ROWS(C1:$C$1)),3,1),"")

Here is an example data sheet (Sheet1)

Here is the filtered data output sheet. You should enter the array formula in the first row and drag downwards to fill expected output range. In this example I select only rowns that have values 1 and A ind filter1 and filter2 columns.

Vba To Find Multiple Files

rrscils598f08@gmail.com (Mitchell Kassulke) — Sat, 30 Sep 2023 20:22:00 +0000

I have this code which finds file names(along with file paths) based on search string.This code works fine in finding single files. I would like this macro to find multiple files a

Solution 1:

I realize this question is very old, but it is unanswered. Here is a quick method for finding multiple files and their paths. VBA's DIR function isn't really very handy, but CMD's DIR function is well optimized and has a plethora of command line switches to make it return only files (or even just folders) that match your criteria. The trick is to call DIRfrom a WScript shell so that the output can be parsed by VBA.

For example, this snippet of code will find every file on your system that starts with config.

Dim oShell AsObject'New WshShell if you want early bindingDim cmd AsObject'WshExec if you want early bindingDim x AsIntegerConst WshRunning = 0Set oShell = CreateObject("Wscript.Shell")
Set cmd = oShell.Exec("cmd /c ""Dir c:\config* /a:-d /b /d /s""")

DoWhile cmd.Status = WshRunning
    DoEvents
Loop

Debug.Print cmd.StdOut.ReadAll
Set oShell = NothingSet cmd = Nothing

Vba - Long Array Formula Via Application.evaluate

rrscils598f08@gmail.com (Mitchell Kassulke) — Sat, 30 Sep 2023 18:55:00 +0000

Say we have some long formula saved in cell A1: =SomeArrayFunction( IF(SUM(D3:D6)>1,'A-B-C-D-E-F-G-H-I-J-K-L-M-N-O-P-Q-R-S-T-U-V-W-X 01', 'part_one'), IF(SUM(D3:D6)>1,'A-B-C-

Solution 1:

I believe that Application.Evaluate will return a result that matches the size of the input address. I suspect that your Selection is a single cell so it is returning a single value.

If instead you call it with Selection.CurrentArray.Address you will get an answer that is the same size as the correct array.

Picture of VBA and Excel

Code to test with

PublicFunctionTest() AsVariantTest = Array(1, 2)


EndFunctionSubt()

    DimaAsVarianta = Application.Evaluate(Selection.CurrentArray.Address)

EndSub

Edit, based on comments here is a way evaluate this off sheet by creating a new sheet. I am using a cut/paste approach to ensure the formulas all work the same. This probably works better if cells don't reference the cut one. It will technically not break any other cells though since I am using cut/paste.

In the code below, I had an array formula in cell J2 it referenced several other cells. It is expanded to have 3 rows and then the Evaluate call is made. That returns an array like you want. It then shrinks it down to one cell and moves it back.

I have tested this for a simple example. I have no idea if it works for the application you have in mind.

Sub EvaluateArrayFormulaOnNewSheet()

    'cut cell with formula
    Dim str_address As String
    Dim rng_start As Range
    Set rng_start = Sheet1.Range("J2")
    str_address = rng_start.Address

    rng_start.Cut

    'create new sheet
    Dim sht As Worksheet
    Set sht = Worksheets.Add

    'paste cell onto sheet
    Dim rng_arr As Range
    Set rng_arr = sht.Range("A1")
    sht.Paste rng_arr

    'expand array formula size.. resize to whatever size is needed
    rng_arr.Resize(3).FormulaArray = rng_arr.FormulaArray

    'get your result
    Dim v_arr As Variant
    v_arr = Application.Evaluate(rng_arr.CurrentArray.Address)

    ''''do something with your result here... it is an array


    'shrink the formula back to one cell
    Dim str_formula As String
    str_formula = rng_arr.FormulaArray

    rng_arr.CurrentArray.ClearContents
    rng_arr.FormulaArray = str_formula

    'cut and paste back to original spot
    rng_arr.Cut

    Sheet1.Paste Sheet1.Range(str_address)

    Application.DisplayAlerts = False
    sht.Delete
    Application.DisplayAlerts = True

End Sub

Solution 2:

Try

vOutput = Application.Evaluate(Selection.CurrentArray.Address)

(assuming you have two cells with =SomeArrayFunction(...) entered as an array formula)

I think the difference may be that evaluating a single cell will only get you the values returned to that cell: the whole array isn't returned there, only the first value.

Excel Vba - Open Files With Variable (dates) Filenames

rrscils598f08@gmail.com (Mitchell Kassulke) — Sat, 30 Sep 2023 18:12:00 +0000

I have the below code to open up files with variable file names, due to dates being in them. I personally save each file daily with the date stamp, ie this morning I saved a file

Solution 1:

That a file exists for last Thursday, yet my code tells me there is none

As I explained in the other question you asked yesterday, putting the vbMonday or vbThursday etc in the Format function doesn't magically tell VBA to return that day:

Hint: The vbFriday part of the Weekday function is not magically telling it to get friday's date. It's actually telling it that, for the sake of this function call, consider Friday to be the first day of the week. The Weekday function then returns an integer (the ordinal day of the week) which it subtracts from the Date.

So, you need to go back and understand how those functions work, you can't just dump constants in there willy-nilly without making an effort to understand what they're doing, or why. On that note, you absolutely need to read this and learn how to begin debugging and troubleshooting first. This describes basics of how to step through your code and examine variable's values/etc at runtime. These techniques are foundations you need to work with VBA.

Here is a list of statements available in VBA. This is documentation that explains things like "How to create a loop structure with For/Next, etc."

And you should go back through the dozen or so questions you've asked here, and mark accepted answers for those where an answer has solved your problem. This is just a basic point of etiquette: You've asked 11 questions here and only accepted 1 answer.

Note also that this sort of declaration does not do what you think it does:

Dim LastFridayDate, MondayDate, TuesdayDate, WednesdayDate, ThursdayDate AsStringDim fullFileNameLastFriday, fullFileNameMonday, fullFileNameTuesday, fullFileNameWednesday, fullFileNameThursday AsStringDim wbkLastFriday, wbkMonday, wbkTuesday, wbkWednesday, wbkThursdayOpen As Workbook

Only the last item in each of those statements are strongly typed, the rest are implicitly variant. You should strongly type all variables when possible, e.g.:

Dim wbkLastFriday As Workbook, wbkMonday As Workbook, wbkTuesday As Workbook, wbkWednesday As Workbook, wbkThursdayOpen As Workbook

And rather than using five different workbook objects (unless you really need 5 workbooks open at once, just use a single workbook object and operate within a loop, opening successive file at each iteration.

Dim wb as Workbook
Dim i asLongFor i = 1to5Set wb = Workbooks.Open(...)
    'Do something
    wb.Close()
Next

Getting to your actual problem:

A function like below will return an array of your date components. This returns the previous 7 days from the FirstDay (which defaults to Friday previous). You can use the Dir function as previously to simply test whether a filename is valid/existing (e.g., Sunday file doesn't exist, etc.), and skip over it if it's not valid.

Function GetFileNames(Optional FirstDay = vbFriday)
Dim filenames(1To7) AsStringDim i AsLongFor i = 1To7
filenames(i) = Format(Date - (Weekday(Date, FirstDay) + i), "m.d.yy")
Next
GetFileNames = filenames
EndFunction

Solution 2:

It seems that you want your search to start from yesterday instead of today. If so, you can try changing

ThursdayDate = Format(Date - (Weekday(Date, vbThursday) - 1), "m.d.yy")

into

ThursdayDate = Format(Date - (Weekday(Date - 1, vbThursday)), "m.d.yy")

and generalize it to other week days. In fact what it does now is that when it runs, say, on this Thursday, it looks up for the file of last Thursday...

Vba To Delete Multiple Rangenames For Single Range

rrscils598f08@gmail.com (Mitchell Kassulke) — Sat, 30 Sep 2023 17:30:00 +0000

I have searched for an answer for hours, and can't search anymore. Have Seen lots of discussions about deleting all range names from a workbook or a worksheet. However, I need to

Solution 1:

You are getting that error becuase you have not set rgName after declaring it.

Here is my understanding of your question.

Lets say there is a Range A1:A10 in Sheet1 and Cell A2 has a name NM1 and Cell A5 has a name NM2 and cell D10 has a name NM3

And you want a piece of code which deletes the Names in Range A1:A10 i.e NM1 and NM2 and not NM3

If the above is what you want then try this

OptionExplicitSub Sample()
    Dim rgName As Range, aCell As Range
    Dim nName As Name

    Set rgName = Sheets("Sheet1").Range("A1:A10")

    ForEach nName In ThisWorkbook.Names
        Set aCell = Range(nName)
        IfNot Intersect(aCell, rgName) IsNothingThen nName.Delete
    NextEndSub

And if I have misunderstood your question then you might want to rephrase it?

FOLLOWUP

This has been an extremely useful site to me as a new VBA user, but I have ABSOLUTELY no idea how to add to this site, beyond these little notes. Please try to imagine the Name Manager in Excel 2010 - in Name Manager there are say 10 unique names, all for =Sheet1!$A$1. I want all of these names which pertain to Sheet1!$A$1 to be deleted by VBA code. I DO NOT want other names to be deleted anywhere. – LostInData 3 mins ago

Based on your above comment try this

OptionExplicitSub Sample()
    Dim nName As Name

    ForEach nName In ThisWorkbook.Names
        If nName.RefersTo = "=Sheet1!$A$1"Then nName.Delete
    NextEndSub

Solution 2:

I think there is something missing in the solution given above.

In order to refer to the range of a named range with the range object you must use the name property of your named range. Therefore, not Set aCell = Range(nName) but rather Set aCell = Range(nName.Name).

Like this:

OptionExplicitSub Sample()
    Dim rgName As Range, aCell As Range
    Dim nName As Name

    Set rgName = Sheets("Sheet1").Range("A1:A10")

    ForEach nName In ThisWorkbook.Names
        Set aCell = Range(nName.Name)
        IfNot Intersect(aCell, rgName) IsNothingThen nName.Delete
    NextEndSub

Check Whether Excel File Is Password Protected

rrscils598f08@gmail.com (Mitchell Kassulke) — Sat, 30 Sep 2023 16:47:00 +0000

I am trying to open an Excel (xlsm) file via VBA. It may or may not be protected with a (known) password. I am using this code: On Error Resume Next Workbooks.Open filename, Passwo

Solution 1:

For the record - the reason was indeed the structure protection of the workbook I was opening. I could circumvent the problem by disabling structure protection, and re-protecting in Workbook_Open() (in the protected workbook).

With structure protection inactive, Workbooks.Open with password does not fail even when there is no password.

Since I am opening via a VBA method, the VBA code is already trusted, meaning the Workbook_Open method will surely be called.

Solution 2:

Use 1004 error handling exclusively for this particular problem, and On Error Resume Next for everything else in the Sub.
Above the statement Workbooks.Open filename, Password:=user_entered_pw also add another line statement without a password argument.
If those (or their combination) don't work, try scouring the .xlsm flat code in Notepad for any hint that a PW protected file differs at that level from one without. Use that info in a pre-opening function.

How To Remove Newline Characters From Csv File

rrscils598f08@gmail.com (Mitchell Kassulke) — Sat, 30 Sep 2023 12:46:00 +0000

I have the below part of code that reads values from the csv file 'prom output.csv' and writes them sorted in a new one 'sorted output.csv'. import collections import csv with ope

Solution 1:

apparently changing the line: cr = csv.writer(f,lineterminator='\n') into: cr = csv.writer(f,sys.stdout, lineterminator='\n') and adding import sys to the imports solves the problem.

Solution 2:

Changing

cr = csv.writer(f,delimiter=",")

cr = csv.writer(f,delimiter=",", lineterminator='\n')

does the trick. I tried cr = csv.writer(f, lineterminator='\n') and it still works.

Solution 3:

This is a simple feasible solution:

import collections
import csv

withopen('prom output.csv') as f:
    header = next(csv.reader(f))
    d = collections.OrderedDict()
    for r in csv.reader(f):
        try:
            d[r[0]] += ','+r[1]
        except:
            d[r[0]] = ','+r[1]

withopen('sorted output.csv', 'w') as f:
    cw = csv.writer(f)
    cw.writerow(header)
    for k, v in d.items():
        f.write(k+v+'\n')

For the input of the following CSV file (prom output.csv):

case,event,startTime,completeTime
101,A
101,B
101,Y
102,C
102,D
102,U
103,A
103,B
103,Y

The output was (sorted output.csv):

case,event,startTime,completeTime
101,A,B,Y
102,C,D,U
103,A,B,Y

Which is the output as you intended it to be.

Solution 4:

The Python newline character is, '\n'. Therefore to remove the newline character (and hence the blank lines that are being printed) from your string, try:

cr.writerow([k, (",".join(v)), .strip("\n")])

How To Read/convert Excel Xml Files To R/csv?

rrscils598f08@gmail.com (Mitchell Kassulke) — Sat, 30 Sep 2023 10:41:00 +0000

I have few hundred XML files. They are probably generated from/to Excel. I would like to read it to R or convert to CSV. Headers of all files look like this:

Solution 1:

There is a chapter in the "R Data Import/Export" manual (one of the free manuals that installs with R) on reading data from Excel spreadsheets. If the above XML file is a saved spreadsheet from recent versions of Excel then some of those tools should read them easily. I would probably start with either the RODBC package or the XLConnect package.

If those don't work then the XML package should at least make writing the parser much easier.

Complex Transformation In Excel Power Query

rrscils598f08@gmail.com (Mitchell Kassulke) — Sat, 30 Sep 2023 07:44:00 +0000

I have 2 input Tables. Input Table1 is the source data and input Table 2 is a criteria table. +--------------------------+----------+ +--------------------------+-------+ |

Solution 1:

Below is the UPDATED solution.

In general, I compiled the solution in order to be as less vulnerable to problems with data, as possible.

The only constrains to data are:

Field sets must have ID field, which must be the first field of set.
all the RRUL and ADDR have to be in pairs,
Duplicates of RRUL/ADDR pairs inside one ID are acceptable or absent.

I also compiled the solution in a way to correctly find the closest value in all possible variants of ADDR and PREFIX. By the way - there is one case, not covered in your bigsample - when PREFIX is shorter then ADDR but not equal to it. If there are such cases - my solution handles them correctly but demands some performance overhead for this particular situation.

let
        Source = #"Source data",
    #"Added Index1" = Table.AddIndexColumn(Source, "Index", 0, 1),

    #"Added Custom" = Table.AddColumn(#"Added Index1", "Main Key", each if [DESCRIPTION] = "ID" then [Index] elsenull, type number),

    #"Added Custom10" = Table.AddColumn(#"Added Custom", "Last notADDR", each 
        if [DESCRIPTION] <> "ADDR" and [DESCRIPTION] <> "RRUL" then [Index] elsenull),

    #"Filled Down" = Table.FillDown(#"Added Custom10",{"Main Key", "Last notADDR"}),

    #"Added Custom2" = Table.AddColumn(#"Filled Down", "Key", each [Main Key] + (
        if [DESCRIPTION] = "RRUL" then [Index] - [Last notADDR] - 2elseif [DESCRIPTION] = "ADDR" then [Index] - [Last notADDR] - 1else0)),

    #"Removed Columns" = Table.RemoveColumns(#"Added Custom2",{"Index", "Main Key", "Last notADDR"}),

    #"Pivoted Column1" = Table.Pivot(#"Removed Columns", 
        List.Distinct(#"Removed Columns"[DESCRIPTION]), "DESCRIPTION", "VALUE"),

    #"Added Custom3" = Table.AddColumn(#"Pivoted Column1", "CODE", each if [ADDR] = null then nullelse let t = Table.AddIndexColumn(Table.SelectRows(Criterias, (x)=> 
        let s=List.Sort({x[PREFIX], [ADDR]}, each Text.Length(_)) in Text.StartsWith(s{1}, s{0})), "Index")
            inif Table.RowCount(t) > 0 then Table.First(Table.Sort(t, (y)=> Number.BitwiseShiftLeft(Number.Abs(Text.Length([ADDR]) - Text.Length(y[PREFIX])), 16) + y[Index]))[CODE] 
            else"Not Found"),
    #"Removed Columns1" = Table.RemoveColumns(#"Added Custom3",{"Key", "ADDR"}),
    #"Filled Down1" = Table.FillDown(#"Removed Columns1",{"ID", "NAME", "TYPE", "DFRUL"})
in
    #"Filled Down1"

Vba Replace All In Column Within Sections Broken By "/"

rrscils598f08@gmail.com (Mitchell Kassulke) — Sat, 30 Sep 2023 05:27:00 +0000

So I have some code that goes through a list of names (most are one username per row). A few of the row have multiple names broken up by the '/' character (John Doe / Smith Jr / So

Solution 1:

Try this:

What:="/*Doe*/", Replacement:="/jdoe/"

And add a trailing / to each cell in the range so it catches entries like some name / john doe

Solution 2:

This should also work, and doesn't require prefix/suffix anything. This processes 100K cells in about 6 seconds (per call to the foo function).

Sub main()
' This is your main procedure and you can specify all _of your replacements here on their own line:

Call foo("*Doe*", "jdoe")
Call foo("*Ruth*", "bruth")
Call foo("*Washington*", "gwashington")
' etc...EndSubSub foo(replace, replacement)
Dim rng As Range, cl As Range, vals

Set rng = Worksheets(2).Range("B1:B100000")  'Modify as neededForEach cl In rng.Cells
    vals = Split(cl.Value, " / ")
    For i = LBound(vals) To UBound(vals)
        If vals(i) Like replace Then
            vals(i) = replacement
        EndIfNext
    cl.Value = Join(vals, " / ")
NextEndSub

Collapsing Pivotfield With Duplicate Occurence /name

rrscils598f08@gmail.com (Mitchell Kassulke) — Sat, 30 Sep 2023 01:42:00 +0000

I have a Pivot Table where I want to use the PivotField('Amount') two times. Once as a row and another as a value/datafield. The reason being is I have 'Total Amounts' for given mo

Solution 1:

It works, try his code.

' doesn't works
PSheet.PivotTables("PivotTable").PivotFields("Desc").PivotItems.ShowDetail = False

'works
PSheet.PivotTables("PivotTable").PivotFields("Desc").ShowDetail = False

' works
Dim pivotItm As PivotItem
 For Each pivotItm In PSheet.PivotTables("PivotTable").PivotFields("Desc").PivotItems
  pivotItm.ShowDetail = False
 Next pivotItm

Vb: Error Loading Type Library/dll. (exception From Hresult: 0x80029c4a (type_e_cantloadlibrary)

rrscils598f08@gmail.com (Mitchell Kassulke) — Fri, 29 Sep 2023 22:53:00 +0000

I am working on an app which needs to import data from Excel. My solution is using Microsoft.office.Interop.Excel. But I get this error when I debug: Message=Unable to cast COM ob

Solution 1:

First of all, try to run Visual Studio with the /ResetUserData command line argument. Read more about that in the Error "Unable to cast COM object..." when exporting to Microsoft Excel from Team Explorer 2008 article.

Obviously you are trying to connect to a wrong Excel version. Looks like you have some extra windows registry keys left after uninstalling an old version of Office or vice versa. Anyway, take a look at the How to solve “Unable to cast COM object of type Microsoft.Office.Interop.Excel.ApplicationClass’ to interface type ‘Microsoft.Office.Interop.Excel._Application’” blog post which describes exactly the same issue. Basically you need to find a wrong entry in the windows registry and then delete it.

BTW When you add a new COM reference to the project a missed PIA is generated automatically (if it doesn't exist any longer). So, that is a possible way to go. Also you may try to embed interop types into your own assembly like the following screenshot shows:

Solution 2:

If you set the Embed Interop Types property to True (since .NET Framework 4.0) and the Specific Version property to False for the Office Interop assembly reference, then your code should work with any version of Excel.

However, you must compile the code with the same bitness as your Office. For a 32-bit version of Office, you must compile your code as x86, otherwise this exception can still occur on a 64-bit machine!

Using Libname Statement In 64 Bit Sas To Interact With 32 Excel

rrscils598f08@gmail.com (Mitchell Kassulke) — Fri, 29 Sep 2023 20:49:00 +0000

I have 64 bit SAS 9.4 installed and 32 bit Office 2007. When I had 32 bit SAS 9.3 installed, I was able to use a libname statement where the Excel file was the library and the 'fi

Solution 1:

With SAS 9.4 or later 9.3 updates, you have another option: dbms=XLSX or dbms=XLS, both of which work regardless of bitness of office (As they're not using the JET engine or ACE engine). Still requre ACCESS to PC FILES, but they should work in mixed bitness systems.

Solution 2:

If you can install SAS PC Files Server, you can still do this with the PCFILES destination. Installing the PC Files Server software is out of the scope of an answer here, but google about for instructions, they are readily available. You can install the PC Files Server on your desktop, or on a central server if that's more convenient for your workplace.

Once you have it installed, you just access it by:

libname mylib pcfiles path="blah\blah\blah.xlsx";

Just like you did before, but with a different dbms type.

Solution 3:

The problem is you need the 64 bit Excel libraries for 64 bit SAS to interact with.

Chris Hemedinger posted a few work arounds to this issue as few years ago. http://blogs.sas.com/content/sasdummy/2012/05/01/64-bit-gotchas/

If you have ACCESS/ODBC, another option is to create an ODBC connection to the Excel spreadsheet.

Refer To Querytable Objects By Name

rrscils598f08@gmail.com (Mitchell Kassulke) — Fri, 29 Sep 2023 18:52:00 +0000

I am developing a MS Excel 2013 tool with VBA, which involves the use of QueryTables. One inconvenience is accessing existing QueryTables within an Excel worksheet. Currently, the

Solution 1:

In Excel 2003 and prior, an external data connection would create a QueryTable object whose parent was a worksheet. You could access the QueryTable object, for one, through the QueryTables collection object. Like most collection objects, you can pass an index number or a name to the (default) Item method to get it.

Sheet1.QueryTables("MyQtName")

When you open a 2003 worksheet in a new version, it still has a QueryTable object and can be accessed the same way. Even if you convert the file format, the QueryTable persists.

In 2007 and later versions, there are only three ways to create a QueryTable that will be a member of Worksheet.QueryTables:

Through code
Data - From Text
Data - From Web

All other UI external data connections in these new versions will result not in a QueryTables member, but in a ListObject. That ListObject will have one and only one QueryTable object that can be accessed via the ListObject.QueryTable property.

Here's the bad news. The QueryTable whose parent in a ListObject doesn't have a Name property. Well, it's there, but you will get a runtime error 1004 if you try to access it. I guess MS decided since there's only one QueryTable per ListObject, it didn't make sense that it should have a name.

If you try to convert a Worksheet.QueryTables.QueryTable into a ListObject, the external data connection goes away and the new ListObject doesn't have a QueryTable.

Since your QueryTables.Count is returning zero, all of your QueryTables are inside ListObjects and don't have names. The ListObjects have names. You can use

Sheet1.ListObjects("MyListName").QueryTable

Here's a function that takes a name and a worksheet and returns a QueryTable that either has that name or is a child of a ListObject that has that name.

PublicFunction QueryTableByName(ByVal sName AsString, ByRef sh As Worksheet) As QueryTable

    Dim qt As QueryTable
    Dim lo As ListObject

    OnErrorResumeNextSet qt = sh.QueryTables(sName)
    OnErrorGoTo0If qt IsNothingThenOnErrorResumeNextSet lo = sh.ListObjects(sName)
        OnErrorGoTo0IfNot lo IsNothingThenOnErrorResumeNextSet qt = lo.QueryTable
            OnErrorGoTo0EndIfEndIfSet QueryTableByName = qt

EndFunction

Solution 2:

According to this MSDN link for ListObject there isn't any collection of QueryTables being a property of ListObjects. Correct code is:

SetQT= querySheet.ListObjects.items(1).QueryTable

What you possibly need is to refer to appropriate ListObject item like (just example code):

Dim LS as ListObject
Set LS = querySheet.ListObjects("My LO 1")
Set QT = LS.QueryTable

The other alternative is to refer to QT through WorkSheet property in this way:

SetQT= Worksheet("QTable").QueryTables("My Query Table")

Solution 3:

This works:

Range("ClassifiedAsSupply").ListObject.QueryTable.Refresh BackgroundQuery:=True

Thanks to Dingbatdata: https://www.dingbatdata.com/2017/11/24/referencing-listobjects-with-vba/#comment-719

Excel Print Number With Correct Decimal Seperator

rrscils598f08@gmail.com (Mitchell Kassulke) — Fri, 29 Sep 2023 17:56:00 +0000

I use the print function to export a Cell Value to csv file. I use this macro on several PCs with different Localization Settings. The problem i am experiencing is, that on some PC

Solution 1:

As far as I'm aware, there is no format method for changing the decimal separator. Instead your options are temporarily telling Excel to use a special character or using Replace().

Application.UseSystemSeparators = False
Application.DecimalSeparator = ";"Print#1, rngValue.Text

Print#1, Replace(rngValue, ",", ";")

In either case you then have a problem, when reading the numbers back in, of converting them back to the correct character so they are considered numbers.

A better question might be how do programmers in places that use the comma as the decimal separator handle decimal values in CSV files?

Activex Can't Create Object Powerpont Vba

rrscils598f08@gmail.com (Mitchell Kassulke) — Fri, 29 Sep 2023 16:46:00 +0000

I am trying to copy 1st slide from the powerpoint and insert it at the end but I am getting ActiveX can't create object on the line ActivePresentation.Slides(1).Copy This is my fu

Solution 1:

Try edited code below, I have ppApp As PowerPoint.Application and Dim ppPres As PowerPoint.Presentation :

Option Explicit

Dim myFile, Fileselected As String, Path As String, objPPT As Object
Dim ppApp   As PowerPoint.Application
Dim ppPres  As PowerPoint.Presentation

Dim activeSlide As PowerPoint.Slide

Sub Generate_PPTs()

Application.ScreenUpdating = False

Set myFile = Application.FileDialog(msoFileDialogOpen)
With myFile
    .Title = "Choose Template PPT File."
    .AllowMultiSelect = False
If .Show <> -1 Then
    Exit Sub
End If
    Fileselected = .SelectedItems(1)
End With
Path = Fileselected

Dim i As Integer

Set ppApp = New PowerPoint.Application
i = 1

ppApp.Presentations.Open Filename:=Path  ' 'PowerPointFile = "C:\Test.pptx"
Set ppPres = ppApp.Presentations.Item(i)

' for debug
Debug.Print ppPres.Name

ppPres.Slides(1).Copy
ppPres.Slides.Paste Index:=ppPres.Slides.Count + 1

Set activeSlide = ppPres.Slides(ppPres.Slides.Count)

Application.ScreenUpdating = True
Set ppPres = Nothing
Set ppApp = Nothing

End Sub

Xml Web Scraping A Website With Dynamic Key

rrscils598f08@gmail.com (Mitchell Kassulke) — Fri, 29 Sep 2023 13:41:00 +0000

I have been scraping this site from Excel using IE but recently using IE has been inconsistent and slow. My list is usually around 500 to 1000 so I have to run the macro over night

Solution 1:

I've submitted the same search request from the web form on the webpage in Firefox. After that I opened Developer Tools F12, Network tab, clicked last POST request, opened Parameters section, and here is a screenshot of the parameters that have been submitted:

Raw Form Data:

__EVENTTARGET=&__EVENTARGUMENT=&__VIEWSTATE=%2FwEPDwULLTEyNDQ4MDU4OTkPZBYCZg9kFgICAw9kFgICDQ9kFgYCAQ9kFgICAw9kFgICAQ8QZBAVARUxNzAwIFNQUklORyBHQVJERU4gU1QVARUxNzAwIFNQUklORyBHQVJERU4gU1QUKwMBZxYBZmQCBQ8PFgIeBFRleHQFHFBsZWFzZSBhZGQgYWRkcmVzcyB0byBsb29rdXBkZAINDw8WAh4HVmlzaWJsZWhkFgoCAQ88KwAKAQAPFgQeC18hRGF0YUJvdW5kZx4LXyFJdGVtQ291bnRmZGQCAw9kFgICBQ8PFgIeF0VuYWJsZUFqYXhTa2luUmVuZGVyaW5naGRkAgUPFCsAAg8WAh8EaGQQFgJmAgEWAg8WBB4LTmF2aWdhdGVVcmwFJC4uL0ZlZWRiYWNrRm9ybS5hc3B4P0JydE5vPTc3MjUzNDcwMB8EaGQPFgQfBQUdfi9QREZzL1BheW1lbnRfQWdyZWVtZW50cy5wZGYfBGhkDxYCZmYWAQVxVGVsZXJpay5XZWIuVUkuUmFkV2luZG93LCBUZWxlcmlrLldlYi5VSSwgVmVyc2lvbj0yMDEwLjEuNTE5LjQwLCBDdWx0dXJlPW5ldXRyYWwsIFB1YmxpY0tleVRva2VuPTEyMWZhZTc4MTY1YmEzZDQWBGYPDxYEHwUFJC4uL0ZlZWRiYWNrRm9ybS5hc3B4P0JydE5vPTc3MjUzNDcwMB8EaGRkAgEPDxYEHwUFHX4vUERGcy9QYXltZW50X0FncmVlbWVudHMucGRmHwRoZGQCBw88KwARAgAPFgQfAmcfA2ZkARAWABYAFgBkAgkPFgIeBXZhbHVlBQk3NzI1MzQ3MDBkGAIFQWN0bDAwJEJvZHlDb250ZW50UGxhY2VIb2xkZXIkR2V0VGF4SW5mb0NvbnRyb2wkZ3JkUGF5bWVudHNIaXN0b3J5DzwrAAwBCGZkBTJjdGwwMCRCb2R5Q29udGVudFBsYWNlSG9sZGVyJEdldFRheEluZm9Db250cm9sJGZybQ9nZD9K5t7genscvOsiNrdPkxL0VHWCYSsS%2FK3EZTRu3h3w&__EVENTVALIDATION=%2FwEWBQKkrNCPCgLRzsWTBwLlpIbACAKV6q2KDQKIvdHyCawQaHbBYSHV%2B%2FVvyLUTUY%2BhSsmbpTvj0W4ycfOa1RCO&ctl00%24BodyContentPlaceHolder%24SearchByAddressControl%24txtLookup=by+Property+Address&ctl00%24BodyContentPlaceHolder%24SearchByBRTControl%24txtTaxInfo=043185500&ctl00%24BodyContentPlaceHolder%24SearchByBRTControl%24btnTaxByBRT=+%3E%3E

Note that there are 7 parameters. All of them should be URL-encoded. I've slightly reworked and modified your code, also added some request headers. The following code works correct for me:

OptionExplicitSub test_66()

    Dim s1 AsStringDim s2 AsStringDim sResp AsStringDim aTmp As Variant
    Dim sBRTNumber AsStringDim sFormData AsStringWith CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "http://www.phila.gov/revenue/realestatetax/default.aspx", False
        .setRequestHeader "Accept", "text/html;charset=UTF-8"
        .setRequestHeader "Accept-Encoding", "identity"
        .setRequestHeader "Accept-Charset", "UTF-8"
        .setRequestHeader "Connection", "keep-alive"
        .send
        sResp = .responseText
    EndWith
    aTmp = Split(sResp, "id=""__VIEWSTATE"" value=""", 2)
    s1 = aTmp(1)
    aTmp = Split(s1, """", 2)
    s1 = aTmp(0)
    aTmp = Split(sResp, "id=""__EVENTVALIDATION"" value=""", 2)
    s2 = aTmp(1)
    aTmp = Split(s2, """", 2)
    s2 = aTmp(0)
    s1 = EncodeUriComponent(s1)
    s2 = EncodeUriComponent(s2)

    sBRTNumber = "043185500"
    sFormData = Join(Array( _
        "__EVENTTARGET=", _
        "__EVENTARGUMENT=", _
        "__VIEWSTATE=" & s1, _
        "__EVENTVALIDATION=" & s2, _
        "ctl00%24BodyContentPlaceHolder%24SearchByAddressControl%24txtLookup=by+Property+Address", _
        "ctl00%24BodyContentPlaceHolder%24SearchByBRTControl%24txtTaxInfo=" & sBRTNumber, _
        "ctl00%24BodyContentPlaceHolder%24SearchByBRTControl%24btnTaxByBRT=+%3E%3E" _
        ), "&")

    With CreateObject("MSXML2.XMLHTTP")
        .Open "POST", "http://www.phila.gov/revenue/realestatetax/default.aspx", False
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .setRequestHeader "Accept", "text/html;charset=UTF-8"
        .setRequestHeader "Accept-Encoding", "identity"
        .setRequestHeader "Accept-Charset", "UTF-8"
        .setRequestHeader "Connection", "keep-alive"
        .setRequestHeader "Host", "www.phila.gov"
        .setRequestHeader "Origin", "http://www.phila.gov"
        .setRequestHeader "Referer", "http://www.phila.gov/revenue/realestatetax/default.aspx"
        .send (sFormData)
        sResp = .responseText
    EndWithWith CreateObject("InternetExplorer.Application")
        .navigate "about:blank"
        .Visible = True
        .document.write sResp
    EndWithEndSubFunction EncodeUriComponent(strText AsString) AsStringStatic objHtmlfile AsObjectIf objHtmlfile IsNothingThenSet objHtmlfile = CreateObject("htmlfile")
        objHtmlfile.parentWindow.execScript "function encode(s) {return encodeURIComponent(s)}", "jscript"EndIf
    EncodeUriComponent = objHtmlfile.parentWindow.encode(strText)
EndFunction

And here is the IE window output:

Countif The Result Of Subtracting Two Arrays Exceeds A Certain Value In Excel

rrscils598f08@gmail.com (Mitchell Kassulke) — Fri, 29 Sep 2023 11:48:00 +0000

I am new to array formulae and am having trouble with the following scenario: I have the following matrix: F G H I J ... R S T U V 1 0 0 1 1

Solution 1:

As an array formula in one cell without volatile functions:

=SUM((MMULT(--(LEN(F2:J5)*LEN(R2:V5)>0),--TRANSPOSE(COLUMN(F2:J2)>0))=5)*(MMULT(F2:J5-R2:V5,TRANSPOSE(--(COLUMN(F2:J2)>0)))>2.5))

should do the trick :D

Solution 2:

Maybe, in say X1 (assuming you have labelled your columns):

=COUNTIF(Y:Y,TRUE)

In Y1 whatever your chosen cutoff (eg 2.5) and in Y2:

=((COUNTBLANK(F2:J2)+COUNTBLANK(R2:V2)=0)*SUM(F2:J2)-SUM(R2:V2))>Y$1

copied down to suit.

Solution 3:

Try this:

=SUMPRODUCT((MMULT(F1:J4-R1:V4,--(ROW(INDIRECT("1:"&COLUMNS(F1:J4)))>0))>2.5)*(MMULT((LEN(F1:J4)>0)+(LEN(R1:V4)>0),--(ROW(INDIRECT("1:"&COLUMNS(F1:J4)))>0))=(COLUMNS(F1:J4)+COLUMNS(R1:V4))))

Solution 4:

I think this will do it, replacing your AND's by multiplies (*):

=SUMPRODUCT(--((SUBTOTAL(9,OFFSET(F1,ROW(F1:F4)-ROW(F1),0,1,COLUMNS(F1:J1)))-SUBTOTAL(9,OFFSET(R1,ROW(R1:R4)-ROW(R1),0,1,COLUMNS(R1:V1)))>2.5)*(SUBTOTAL(2,OFFSET(F1,ROW(F1:F4)-ROW(F1),0,1,COLUMNS(F1:J1)))=COLUMNS(F1:J1))*(SUBTOTAL(2,OFFSET(R1,ROW(R1:R4)-ROW(R1),0,1,COLUMNS(R1:V1)))=COLUMNS(R1:V1))>0))

It could be simplified a bit more but a bit short of time.

Solution 5:

Just another option...

=IF(NOT(OR(IFERROR(MATCH(TRUE,ISBLANK(F1:J1),0),FALSE),IFERROR(MATCH(TRUE,ISBLANK(R1:V1),0),FALSE))), SUBTOTAL(9,F1:J1)-SUBTOTAL(9,R1:V1), "Missing Value(s)")

My approach was a little different from what you tried to adapt from @TomSharp in that I'm validating the cells have data (not blank) and then perform the calculation, othewise return an error message. This is still an array function call, so when you enter the formulas, press ctrl+shft+enter.

The condition part of the opening if() checks to see that each range's cells are not blank: if a match( true= isblank(cell)) means a cell is blank (bad), if no match ... ie no blank cells, Match will return an #NA "error" (good). False is good = Errors found ? No. ((ie no blank cells))

Then the threshold condition becomes:

=COUNTIF(X1:X4,">"&Threshold)' Note: no Array formula here

I gave the threshold (Cell W6) a named range for read ablity.

Vba: Loop Through Rows, Sum Up Certain Rows If Condition Is Met

rrscils598f08@gmail.com (Mitchell Kassulke) — Fri, 29 Sep 2023 10:47:00 +0000

I have been using the forums for a couple of weeks now while learning VBA. But now I am stuck and need help. So here is my problem: I have a workbook with several worksheets in it.

Solution 1:

You're close, but you need to test each cell individually inside your loop. Something like this:

Sub Macro1()
    Dim tbl As Worksheet
    Dim x AsIntegerDim lrow AsLongDim lastname AsStringDim astatus AsStringDim number AsIntegerDim counter AsInteger: counter = 3Set wb = ThisWorkbook
    Set tbl = wb.Sheets("Sheet1")
    lrow = tbl.Cells(Rows.Count, "B").End(xlUp).Row

    For x = 2To lrow
        If tbl.Range("C" & x) = "Smith"And tbl.Range("E" & x) = "Talking"Then
            Range("I" & counter).Value = Range("C" & x)
            Range("J" & counter).Value = Range("E" & x)
            Range("K" & counter).Value = Range("H" & x)
            counter = counter + 1EndIfNext x
EndSub

Per @Tim comment you can use SumIfs to return the total of 'H' column that meet multiple criteria like this:

=SUMIFS(H:H,C:C,"=Smith",E:E,"=Talking")

Solution 2:

I found a way that does the job for me so far, but this seems pretty messed up since I have to do it for every case manually. So now I am looking for a simpler and more elegant way to do this. If you could provide me with some code or point me into the right direction, I would highly appreciate it.

Here is my code so far:

ForEach cell InRange("H2:H" & lrow)
   cell.Offset(0, 1).Value= cell.Value + cell.Offset(-1, 1).Value
      If cell.Offset(0, -6).Value= "Smith" And cell.Offset(0, -3).Value= "Talking" Then
      cell.Offset(0, 2).Value= cell.Value
      End If

      If cell.Offset(0, -6).Value= "Smith" And cell.Offset(0, -3).Value= "Ready" Then
         cell.Offset(0, 3).Value= cell.Value
      End If

      If cell.Offset(0, -6).Value= "Smith" And cell.Offset(0, -3).Value= "Not Ready" Then
      cell.Offset(0, 4).Value= cell.Value
      End If
Next

As mentioned before, it is a workaround which I would like have to be simplified. It looks for the condition "Smith" and the status "Talking", "Ready" and "Not Ready" and puts the value of the H Column into the respective cells of the columns to it's right to be summed in the later process. So, is there any way to make that more elegant?

Solution 3:

Sure thing Portland Runner! My logic is simple. I've got list of recorded activities for each name with certain statusses. e.g. "Smith" (column B) and "Talking" (column C) and a number (column H). And I need to sum up the numbers in column H for every row where the conditions name and status are equal. Let's say I have 10k rows. 2k of them have the name "Smith" in it. But only 500 of them have the name "Smith" and the status "Talking". So I need to figure out a simpler way to sum up those numbers. There are also rows where the name is "Smith" but the status is "Ready". The difficulty here is, that those lines are basically in a random order.

So the table would look like this:

RowNameStatusNumber2SmithTalking1053SmithTalking674SmithReady755SmithTalking946JonesReady897JonesTalking2248JonesNotReady759JonesTalking99

So in this case row number 1 would be blocked for the headline and the data would start in row number 2. For "Smith" and "Talking" the code would need to sum the numbers of rows 2,3 and 5 for the condition "Smith" and "Talking". Rows 4 for "Smith" and "Ready". Rows 7 and 9 for "Jones" and "Talking" and so on.

What I can do, is create a new worksheet and put a list of all names in column A and a list of all statusses into column B and reference to it. That would save me the trouble of using the exact names and statusses in the code, but wouldn't solve my problem.

Solution 4:

A. Get all unique Name and place in a new column: this will be your array used to search each row.

B. Set up another array for Status since you know what the status could be.

C. Set up outer loop for Name Array For each item in array

D. Nested loop look at each row and search on each status

C. When status matches then another nested loop to add time and place in a new column called total time.

Array Prepared Within A Vba Event. How To Extract Its Contents From Inside A Different Event?

rrscils598f08@gmail.com (Mitchell Kassulke) — Fri, 29 Sep 2023 09:49:00 +0000

This question should apply to any VBA situ with events: I've filled an array within a Form_Load() event in MS Access. Now I would like to extract, dereference, the contents of tha

Solution 1:

Let's start with a simple single Dimension example. Tested in access 2010.

OptionCompare Database
OptionExplicitDim singleArray() AsString'start with one elementDim currentLength AsInteger'variable to keep track of number of elementsPrivateSub Command0_Click()
    Debug.Print "Accessed from Event " & singleArray(0) 'access from eventCall PrintArray 'calling function to print arrayEndSubPrivateSub Form_Load()

    'make 3 calls to my function to populate arrayCall PopulateArray("val1")
    Call PopulateArray("val2")
    Call PopulateArray("val3")

    'print itCall PrintArray

EndSubSub PopulateArray(value AsString)
   'all arrays are 0 based by default, so the first time it is called, it will create 1 element at position 0ReDimPreserve singleArray(currentLength)

    'put the value in the array
    singleArray(currentLength) = value

    'increment variable so the next time the function is called, the value will be placed one position higher
    currentLength = currentLength + 1EndSubSub PrintArray()
    Dim x AsInteger'loop through array and print valuesFor x = LBound(singleArray) To UBound(singleArray)
        Debug.Print singleArray(x)
    NextEndSub

Edit: double array sample, knowing the bounds up front

OptionExplicitDim doubleArray() AsString'array declaration that will become two element arrayDim currentLength AsInteger'variable to keep track of number of elements for array 1PrivateSub Command0_Click()
    Debug.Print "Accessed from Event " & doubleArray(0, 0) 'access from eventCall PrintArray 'calling function to print arrayEndSubPrivateSub Form_Load()

    Dim arrayLength AsInteger, arrayWidth AsInteger'determine bounds of array
    arrayLength = 2'can you write code to determine the length before you start adding records?
    arrayWidth = 1'if you have a fixed number of elements on each "record", this can stay the sameReDim doubleArray(0To arrayLength, 0To arrayWidth)

    Call PopulateDoubleArray("val11", "val12")
    Call PopulateDoubleArray("val21", "val22")
    Call PopulateDoubleArray("val31", "val32")

    Call PrintArray


EndSubSub PopulateDoubleArray(value AsString, value2 AsString)

    'put the value in the array
    doubleArray(currentLength, 0) = value
    doubleArray(currentLength, 1) = value2

    'increment variable so the next time the function is called, the value will be placed one position higher
    currentLength = currentLength + 1EndSubSub PrintArray()
    Dim x AsInteger'loop through array and print valuesFor x = LBound(doubleArray) To UBound(doubleArray)
        Debug.Print doubleArray(x, 0) & " " & doubleArray(x, 1)
    NextEndSub

Solution 2:

If you had Option Explicit in your module, it would have directly given you a compiler error about the ambiguous variable name Arr.

You can't have the same name for a variable and a function.

Additionally, this line enforces variable declaration and reports undeclared variables/constants already at compile time.

To have this automatically in new modules, set the Require Variable Declaration option in the VBA Editor. This is really a must have for VBA development.

Vba - Count Empty Cols, Search And Replace

rrscils598f08@gmail.com (Mitchell Kassulke) — Fri, 29 Sep 2023 08:00:00 +0000

I'm learning VBA and trying to do something a bit complicated for me. Here's the deal : In my 'H' column, I'm using the 'CONCATENATE' formula to get a key of all the elements I wa

Solution 1:

For sure there are methods to avoid the pattern from the very beginning, but this is a Macro to do a (late) cleanup:

Sub Cleanup()
    Dim cel As Range, i AsLongWith Worksheets("Products").UsedRange.Columns("J")
        For i = 1To5
           .Replace "- - ", "- "NextForEach cel In .Cells
            If Trim(cel.Value) = "-"Then cel.Clear
        NextEndWithEndSub

EDIT:

Since you and I dont have TextJoin, and it is an excellent solution proposed by the pals, let us have it as UDF. You can add the code below to any non-class code module and use it as User-Defined-Formula (UDF):

Public Function TextJoin(ByVal sep As String, ByVal ignoreEmpty AsBoolean, ByRef ar As Variant) As String

    Dim cel AsRangeForEach cel In ar
        If Trim(cel.Text) <> "" OrNot ignoreEmpty Then
            If TextJoin <> "" Then TextJoin = TextJoin + sep
            TextJoin = TextJoin + cel.Text
        End If
    Next
EndFunction