VBA and lag - how to fix

[Rise]

So I have this cool new function that Hans directed me to in a previous posting known as "Vlookupall" and it's great. The thing is, it runs allllll the time and so it makes data entry onthe spreadsheet difficult due to the laggy feeling when entering info. What I'd like to do is make it a part of another macro that is currently hot keyed to ctrl+p that gets run and is done. I'm not sure how to do this or if it's even doable - I would imagine I would just call out the macro in the ctrl+p function as another function for the cells that it is normaly used in. Here's the macros I have right now that I would like to combine in this 1 operation.

Ctrl+P macro

Code: Select all

Sub PCRUNORDER()
'
' PCRUNORDER Macro
'
' Keyboard Shortcut: Ctrl+p
'
    Range("A1:D50").Select
    ActiveWorkbook.Worksheets("Run Order").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Run Order").Sort.SortFields.Add Key:=Range( _
        "B2:B50"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Run Order").Sort.SortFields.Add Key:=Range( _
        "C2:C50"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Run Order").Sort
        .SetRange Range("A1:D50")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("B13").Select
End Sub

The vlookupall Macro:

Code: Select all

Option Explicit

Function VLookupAll(vValue, rngAll As Range, iCol As Integer, Optional sSep As String = ", ")
    Dim rCell As Range
    Dim rng As Range
    On Error GoTo ErrHandler
    Set rng = Intersect(rngAll, rngAll.Columns(1))
    For Each rCell In rng
        If rCell.Value = vValue Then _
            VLookupAll = VLookupAll & sSep & _
                rCell.Offset(0, iCol).Value
    Next rCell
    If VLookupAll = "" Then
        VLookupAll = CVErr(xlErrNA)
    Else
        VLookupAll = Right(VLookupAll, Len(VLookupAll) - Len(sSep))
    End If
ErrHandler:
    If Err.Number <> 0 Then VLookupAll = CVErr(xlErrValue)
End Function

And a remove duplicate macro that I would like to get in there as well:

Code: Select all

Sub DelDups_OneList()
Dim iListCount As Integer
Dim iCtr As Integer

' Turn off screen updating to speed up macro.
Application.ScreenUpdating = False

' Get count of records to search through.
iListCount = Sheets("Sheet1").Range("A1:A1000").Rows.Count
Sheets("Sheet1").Range("A1").Select
' Loop until end of records.
Do Until ActiveCell = ""
   ' Loop through records.
   For iCtr = 1 To iListCount
      ' Don't compare against yourself.
      ' To specify a different column, change 1 to the column number.
      If ActiveCell.Row <> Sheets("Sheet1").Cells(iCtr, 1).Row Then
         ' Do comparison of next record.
         If ActiveCell.Value = Sheets("Sheet1").Cells(iCtr, 1).Value Then
            ' If match is true then delete row.
            Sheets("Sheet1").Cells(iCtr, 1).Delete xlShiftUp
               ' Increment counter to account for deleted row.
               iCtr = iCtr + 1
         End If
      End If
   Next iCtr
   ' Go to next record.
   ActiveCell.Offset(1, 0).Select
Loop
Application.ScreenUpdating = True

End Sub

So I guess my first question is - how do you reference a macro for particular cells in VBA? I think that I need to do something like this:

Code: Select all

With ActiveWorkbook.Worksheets("Run Order").Sort
        .SetRange Range("E1:E50")
        'insert vlookupall function here somehow for all of the rows(?)

or maybe it's not with the sort function? I'm pretty confused. I think I just need a poke in the right direction

-John

[HansV]

Please explain in words what you want to accomplish - from all this code it's not clear what you're trying to do.

[HansV]

Not having received further information I can only make a guess at what you want.

The following macro assumes that
- You want to concatenate the values in column D that have the same value in column A, and
- You then want to weed out duplicates in column A.

This could be accomplished using the following code:

Code: Select all

Sub SortGatherAndDelete()
  Const strCompareCol = "A"
  Const strValueCol = "D"
  Dim r As Long
  Dim m As Long
  Dim strVal As String
  ' You can add one or two extra sort keys Key2 and Key3
  Range("A1").CurrentRegion.Sort _
    Key1:=Range(strCompareCol & "1"), _
    Header:=xlYes
  m = Range(strCompareCol & Rows.Count).End(xlUp).Row
  For r = m To 2 Step -1
    If Range(strCompareCol & r).Value = Range(strCompareCol & (r - 1)).Value Then
      strVal = Range(strValueCol & r).Value & ", " & strVal
      Range(strCompareCol & r).EntireRow.Delete
    Else
      strVal = Range(strValueCol & r) & ", " & strVal
      Range(strValueCol & r).Value = Left(strVal, Len(strVal) - 2)
      strVal = ""
    End If
  Next r
End Sub

See the attached sample workbook.

SortGatherAndDelete.xlsm

[Rise]

Sorry, I was trying to do two things at once and I ended up doing two things poorly at once!

What I am trying to do is merge some macros that I have together. As of now, my boss made a macro that basically sorts a list of 4 columns - that was the first macro in my previous post. The point of that is to get our parts ordered for production in the most efficient way possible. What I'm doing is marrying my inventory list that finds rack locations of the various parts they need to run.

His function is run with a control+P short cut, which makes things appear easy for the scheduler. My inventory list uses that vlookupall function which constantly refreshes. The vlookupall function only needs to run when the scheduler runs the scheduling (sorting) macro. So what I wanted to do was take the vlookupall function out of the cells that it is currently residing in and only have it run when the scheduling macro is run to keep the excel work book lag-free (which I don't know how to do).

The last macro is actually just another macro I found on the microsoft help website that removes duplicates. This is kind of a secondary function that doesn't need to occur during the scheduling macro but I thought I might try to put it in there out of convenience. It's actually supposed to run on a different sheet from the other macros, dealing with the backend data directly. So the data entry person adds all these new rows to the data sheet and the duplicate killer would sort that all out to avoid having extra rows that would throw off the vlookupall. This portion of what I want to do may be best suited for a different post... let's focus on just combining the other two for now and I can come up with a better example later to make things a bit easier for both you and me to understand

edit: my apologies for being so slow to respond back to this, I keep getting pulled away from my desk at work. Let me check out what you put together...

[HansV]

The macro that I posted may be overkill. But it's still not clear to me how the first two macros could fit together...

[Rise]

ha, I ran your spreadsheet macro like 10x half because I didn't know what it was doing at first, and then the other half because it was somewhat entertaining to watch

It looks like that's on the right track of what I want to do, I now just need to see how it works with our data and see how to add sorting keys.

[Rise]

The macro that I posted may be overkill. But it's still not clear to me how the first two macros could fit together...

Yeah I realized that as I looked through yours. Let me attach an example spreadsheet to hopefully clear stuff up a bit...

note: in the attached spreadsheet, the formula you gave me to help break the numeric values from the letters stopped working
=1*MID(A2,MATCH(FALSE,ISERROR(1*MID(A2,ROW($1:$10),1)),0),10)

it's way too late in the day, my brain is starting to hurt!

PC scheduling program (safe).xlsm

[Rise]

It may be beneficial for me to attach an example of a spreadsheet that has the core locations correctly listed on it as well.

6_9 Schedule.xlsm

[HansV]

note: in the attached spreadsheet, the formula you gave me to help break the numeric values from the letters stopped working
=1*MID(A2,MATCH(FALSE,ISERROR(1*MID(A2,ROW($1:$10),1)),0),10)

That's easy to solve: it should be an array formula, i.e. confirm with Ctrl+Shift+Enter instead of just Enter. Then fill down again.

[Rise]

quick note - I changed the pc scheduling program to take out some information that could potentially be considered proprietary (i don't think it is) but please don't post the full version back up

also - I still can't seem to get that array function to work. it gives me a #N/A error

[HansV]

So what should I do? Replace the Inventory sheet? I'm getting more and more confused.

[Rise]

I'm sorry. Half the problem is I'm confused too and have been working on this for too long.

I just cut out info from the "Lookup" sheet that had part dimensions on it.

[HansV]

Column C in the Inventory sheet (in PC scheduling program.xlsm) contains a number of values that don't fit the pattern of letters followed by a number, e.g. 2K713X. These values cause the array function to return #VALUE, and this in turn messes up the VLookupAll function. Would it be feasible to make ALL entries fit the pattern letters+number?

[Rise]

I can fill those lines with some generic code like (WTF12345) since I don't know what they are anyway which means they are just random parts taking up my spaces! I can tell the data entry person to just use whatever that generic code is when we run into parts that don't follow the correct letter/number code.

Alternatively, wouldn't they just not show up in the vlookupall? We would never be looking for those anyway so if they don't hurt things if they aren't called, does it matter?

[HansV]

The way it is now, any error in the lookup column value will cause VLookupAll to return #VALUE.

Here is a version of the function that will ignore error values:

Code: Select all

Function VLookupAll(vValue, rngAll As Range, iCol As Integer, Optional sSep As String = ", ")
    Dim rCell As Range
    Dim rng As Range
    On Error GoTo ErrHandler
    Set rng = Intersect(rngAll, rngAll.Columns(1))
    For Each rCell In rng
        If rCell.Value = vValue Then _
            VLookupAll = VLookupAll & sSep & _
                rCell.Offset(0, iCol).Value
NextCell:
    Next rCell
    If VLookupAll = "" Then
        VLookupAll = CVErr(xlErrNA)
    Else
        VLookupAll = Right(VLookupAll, Len(VLookupAll) - Len(sSep))
    End If
ErrHandler:
    Select Case Err
    Case 0
        ' No need to do anything
    Case 13
        ' Type mismatch - resume
        Resume NextCell
    Case Else
        VLookupAll = CVErr(xlErrValue)
    End Select
End Function

[Rise]

sorry for the delayed response, haven't had time to work on this in a bit.

it looks great thanks Hans!