VBA Search-Copy-Paste in userform is running slow

[CLE81]

Hello all,

I have an Excel VBA in a userform which is running quit slow.
(It's programmed in a Userform because I want to show the pogress with a progress bar.)

Case:
I have an VBA script in an Userform which has to search in a long list with items (sheet 1). The keyword which is used to search is configured on another sheet (sheet 2). When a keyword is found in the large list, the entire row has to be copied an paste in a specific worksheet (sheet 3).

There can be configured more then one keywords on the config sheet (sheet 2) and there are more items on the config sheet with their own keywords.

This find-copy-paste action has to be done twice because there are 2 languages configured (2 kind of sheet 1)

As attachement and image for more explanation.

Problem:
At this moment my VBA is searching the entire list of items with the keywords one-by-one which is taking a very long time.

Question:
Is there an option in VBA to search-copy-paste row with a range of variables so this action is taking less time?
Or
Did I program an code which does to many handlings?
At the moment there are 5000 rows * 6 items * with each +/- 4 keywords * 2 languages = 124000 scan/ check actions an it takes approx. 10 minutes.


Code:

Private Sub UserForm_Activate()
' ---------------------- Declare variables -------------------------------------------
    Dim i, j, k, m As Integer
    Dim HMI_name, HMI_Class, HMI_destination, sh_source As String

    HMI_config = "HMI_Config"
    searchcolumn = "E"
     
    'Count configured lanuages
    sh_name = "Select"
    AmountLanguages = Sheets(sh_name).Cells(Rows.Count, 5).End(xlUp).Row
   
    For m = 2 To AmountLanguages
            'Set language
            Language = ActiveWorkbook.Sheets(sh_name).Cells(m, 5)
           
' ---------------------- Search for available HMI's ----------------------------------
          Final_HMI = Sheets(HMI_config).Cells(1, ActiveSheet.Columns.Count).End(xlToLeft).Column
               
          For k = 1 To Final_HMI
            HMI_destination = "#" & ActiveWorkbook.Sheets(HMI_config).Cells(1, k) & "_" & Language
                  
            ' Search for HMI destination
            If (HMI_destination <> "") Then
                   
    ' ---------------------- Search for configured Alarm class ----------------------------
                    Final_Class = Sheets(HMI_config).Cells(Rows.Count, k).End(xlUp).Row
   
                    For j = 2 To Final_Class
                        HMI_Class = Sheets(HMI_config).Cells(j, k)
                       
                            If (HMI_Class <> "") Then
                                                               
    ' ---------------------- Copy/ Paste alarms in correct HMI sheet ----------------------
                                Dim Finalrow As Integer
                               
                                sh_source = "DiscreteAlarms_" & Language
                               
                                Finalrow = Sheets(sh_source).Cells(Rows.Count, 1).End(xlUp).Row
                               
                                ' Loop through each row of overall alarmlist
                                For i = 2 To Finalrow
                                   
                                    ' Decide if to copy based on column Class
                                    Column_txt = Sheets(sh_source).Range(searchcolumn & i)
                                    If InStr(1, Column_txt, HMI_Class) <> 0 Then
                                        'Copy
                                        Sheets(sh_source).Cells(i, 1).Resize(1, 33).Copy
                                        'Paste
                                        NextRow = Sheets(HMI_destination).Cells(Rows.Count, 1).End(xlUp).Row + 1
                                        ActiveSheet.Paste Destination:=Worksheets(HMI_destination).Cells(NextRow, 1)
                                        Application.CutCopyMode = False
                                End If
                            Next i
    ' ---------------------------------------------------------------------------------------
                        End If
                    Next j
    ' ---------------------------------------------------------------------------------------
                End If
            Next k
    ' ---------------------------------------------------------------------------------------
        Next m
    ' ---------------------------------------------------------------------------------------
   
    'Open frontpage[ATTACH type="full"]26636[/ATTACH]
    ActiveWorkbook.Sheets("Voorblad").Activate
    Application.ScreenUpdating = True
End Sub

 

[Anthony47]

The first move should be to copy into a memory array the content fo "DiscreteAlarms_xxx" and loop though this copy rather then though the worksheet; but further algorithm could be developed for increased results.
However for this we would need a sample workbook with sample data to be used for development and tests

Bye

 

[CLE81]

I want to post sample code but how can I attach an Excel workbook in this forum? I can't find a button to add it.....

I 've tried drag-and-drop but it didn't work.

Br

 

[Anthony47]

To share a file you need to upload it to a filesharing service, for example filedropper.com; then you will publish the link your file will be assigned

Bye

 

[CLE81]

http://www.filedropper.com/macrov124mre

 

[Anthony47]

It took some time, but I went to a reasonable revision…
Replace your Private Sub UserForm_Activate with the following code:

 Private Sub UserForm_Activate()
' --- Declare variables ----
Dim DBG As Boolean
Dim I As Long, J As Long, K As Long, M As Long
Dim HMI_name, HMI_Class, HMI_destination, sh_source As String
Dim HMI_Config As String, SearchColumn, Sh_Name As String
Dim AmountLanguages, Language As String, FinalRow As Long, Column_Txt As String
Dim NextRow As Long, myTim As Single, OneLine()
Dim mArr(1 To 5)    'debug only
Dim SSArr           'Array for Source Alarms content
Dim HMIArr          'Array for HMI_Config
Dim ShYes As Boolean, DestSh As String, tSh As String

DBG = False
myTim = Timer
Debug.Print "Start UForm"
'
HMIArr = Sheets("HMI_Config").Range("A1").CurrentRegion.Value   'Copy of HMI_Config
If DBG Then Debug.Print UBound(HMIArr), UBound(HMIArr, 2)
HMI_Config = "HMI_Config"
SearchColumn = 5                  ' 5=E
'
'Amount languages
Sh_Name = "Select"
AmountLanguages = Sheets(Sh_Name).Cells(Rows.Count, 5).End(xlUp).Row
'
'for m      'Different languages
    For M = 2 To AmountLanguages
'****** Language PROGRESS BAR
        Me.LabelProgress1.Width = 200 * (M - 1) / (AmountLanguages - 1)
        Me.LabelProgress1 = "#" & M - 1 & "of " & (AmountLanguages - 1)
            'Set language
            Language = ActiveWorkbook.Sheets(Sh_Name).Cells(M, 5)
'>>>>> Clear sheets and set headers for the language
            For J = 1 To UBound(HMIArr, 2)
                tSh = "#" & HMIArr(1, J) & "_" & Language
                ShYes = ShAvail(ActiveWorkbook, tSh)
                If ShYes Then
                '!!! CLEAR THE DESTINATION SHEET before filling again
                    Sheets(tSh).Cells.ClearContents         '<<<  CLEAR
                    Sheets(tSh).Range("A1").Resize(1, 15).Value = _
                      Array("ID", "Name", "Text []", "Info", "Class", "Trigger tag", "Trigger bit", "Trigger mode", "Test bit", "Test bit 2", "Test Tag", "Test Tag bit", "Misc1", "Misc2", "MiscInfo []")
                Else
                'Missing sheet!
                    MsgBox ("Worksheet " & tSh & " seem to be missing; the process will be aborted")
                    GoTo eForm
                End If
            Next J
            DoEvents
            sh_source = "DiscreteAlarms_" & Language
            FinalRow = Sheets(sh_source).Cells(Rows.Count, 1).End(xlUp).Row
            SSArr = Sheets(sh_source).Range("A1").Resize(FinalRow, 33).Value
            If DBG Then Debug.Print Format(Timer - myTim, "0.00"), "Start processing " & sh_source, FinalRow
            If DBG Then Debug.Print UBound(SSArr), UBound(SSArr, 2)
            ReDim OneLine(1 To UBound(SSArr, 2))
            ' Loop through each row of itemlist
            For I = 2 To FinalRow
'****** Rows PROGRESS BAR
                    Me.LabelProgress2.Width = 200 * I / FinalRow
                    'debug info every 100 lines:
                    If I Mod 100 = 0 Then           'print time every 100 lines, debug purpose
                        Debug.Print Format(Timer - myTim, "0.00"), I
                        DoEvents
                    End If
                    ' Decide WHERE to copy based on column Class
                    Column_Txt = SSArr(I, SearchColumn)
                    DestSh = "#" & ItemVal(HMIArr, Column_Txt) & "_" & Language
                    If ShAvail(ActiveWorkbook, DestSh) Then
                        NextRow = Sheets(DestSh).Cells(Rows.Count, 1).End(xlUp).Row + 1
                        'Copy one line of data
                        For J = 1 To UBound(OneLine)
                            OneLine(J) = SSArr(I, J)
                        Next J
                        'dump to the output sheet
                        Sheets(DestSh).Cells(NextRow, 1).Resize(1, UBound(OneLine)).Value = OneLine
                    Else
                        'Missing sheet??
                        MsgBox ("Worksheet " & DestSh & " seem to be missing; the process will be aborted")
                        GoTo eForm
                        Stop
                    End If
                DoEvents
            Next I
        Next M
    ' ---------------------------------------------------------------------------------------
eForm:
    
    'Openen voorblad
'    ActiveWorkbook.Sheets("Frontpage").Activate
    Application.ScreenUpdating = True
    Unload Me
Debug.Print Format(Timer - myTim, "0.00"), Now, "Unload UForm"
End Sub

Function ItemVal(ByRef DArr, CellTxt As String) As String
Dim I As Long, J As Long

For I = 1 To UBound(DArr)
    For J = 1 To UBound(DArr, 2)
        If InStr(1, CellTxt, DArr(I, J), vbTextCompare) > 0 Then
            ItemVal = DArr(1, J)
            Exit Function
        End If
    Next J
Next I

End Function
Function ShAvail(tWb As Workbook, tSh As String) As Boolean
    On Error Resume Next
        ShAvail = UCase(tWb.Sheets(tSh).Name) = UCase(tSh)
    On Error GoTo 0
'If ShAvail = False Then Stop
End Function

This code is compatible with your Userform, but I use only 2 of the "progress labels"; so maybe you should clean your userform. The sample workbook I used can be downloaded from here:

byCLE81-Mr_Macro_V1.24_MRE_C01124.xlsm

Shared with Dropbox

www.dropbox.com

(it is your workbook, with my reduced userform and my new code)

The macro scans the "language worksheets" (source), and allocate each line to the proper destination worksheet (that is I don't search one class after the other).
Also I tried to speed up the process by copying the source data into memory array.
This makes the process much speedier than the original one; and hopefully also as accurate as the original macro..

Note also that I CLEAR THE OUTPUT SHEETS before starting the new distribution process; it this is wrong then look for the line '!!! CLEAR THE DESTINATION SHEET before filling again and clear the line that follow that comment.

I didn't try to understand how you managed the progress labels, and managed them "may way" (see the two line marked '****** xxxxxxx PROGRESS BAR); so your Sub progress is not used now and probably can be deleted.

Try my modified workbook, and if it is suitable try to move the said modifications to your workbook.

Bye

 

[CLE81]

Hello Anthony47,

Thank you very much for reviewing and optimizing my VBA code. I'm gonna test and implement it tommorow.

For what I see now it is working much faster then my code.

br

 

[CLE81]

I 'm very pleased to see the VBA is running lightning fast!

 

[CLE81]

Unfortunately is it not working correctly.

I ve tried the attached configuration and there are lines copied to sheet where they not belong and other sheets are empty when there are classes double declared in different items.

A line can be needed in more then one sheet.

I'm a VBA rookie and I don't understand the entire VBA code.

Can someone help me further?

br

 

[Anthony47]

I didn't realize that the same class could belong to different category… Also my algorithm was weak and considered _CC same as _C
The new code that deal with these errors is this:

Private Sub UserForm_Activate()                                     'V2, C01126

' --- Declare variables ----
Dim DBG As Boolean
Dim I As Long, J As Long, K As Long, M As Long
Dim HMI_name, HMI_Class, HMI_destination, sh_source As String
Dim HMI_Config As String, SearchColumn, Sh_Name As String
Dim AmountLanguages, Language As String, FinalRow As Long, Column_Txt As String
Dim NextRow As Long, myTim As Single, OneLine()
Dim mArr(1 To 5)    'debug only
Dim SSArr           'Array for Source Alarms content
Dim HMIArr          'Array for HMI_Config
Dim ShYes As Boolean, DestSh As String, tSh As String
Dim KK As Long, hSh As String                                         'V2

DBG = False
myTim = Timer
Debug.Print "Start UForm"
'
HMIArr = Sheets("HMI_Config").Range("A1").CurrentRegion.Value   'Copy of HMI_Config
If DBG Then Debug.Print UBound(HMIArr), UBound(HMIArr, 2)
HMI_Config = "HMI_Config"
SearchColumn = 5                  ' 5=E
'
'Amount languages
Sh_Name = "Select"
AmountLanguages = Sheets(Sh_Name).Cells(Rows.Count, 5).End(xlUp).Row
'
'for m      'Different languages
    For M = 2 To AmountLanguages
'****** Language PROGRESS BAR
        Me.LabelProgress1.Width = 200 * (M - 1) / (AmountLanguages - 1)
        Me.LabelProgress1 = "#" & M - 1 & "of " & (AmountLanguages - 1)
            'Set language
            Language = ActiveWorkbook.Sheets(Sh_Name).Cells(M, 5)
'>>>>> Clear sheets and set headers for the language
            For J = 1 To UBound(HMIArr, 2)
                tSh = "#" & HMIArr(1, J) & "_" & Language
                ShYes = ShAvail(ActiveWorkbook, tSh)
                If ShYes Then
                '!!! CLEAR THE DESTINATION SHEET before filling again
                    Sheets(tSh).Cells.ClearContents         '<<<  CLEAR
                    Sheets(tSh).Range("A1").Resize(1, 15).Value = _
                      Array("ID", "Name", "Text []", "Info", "Class", "Trigger tag", "Trigger bit", "Trigger mode", "Test bit", "Test bit 2", "Test Tag", "Test Tag bit", "Misc1", "Misc2", "MiscInfo []")
                Else
                'Missing sheet!
                    MsgBox ("Worksheet " & tSh & " seem to be missing; the process will be aborted")
                    GoTo eForm
                End If
            Next J
            DoEvents
            sh_source = "DiscreteAlarms_" & Language
            FinalRow = Sheets(sh_source).Cells(Rows.Count, 1).End(xlUp).Row
            SSArr = Sheets(sh_source).Range("A1").Resize(FinalRow, 33).Value
            If DBG Then Debug.Print Format(Timer - myTim, "0.00"), "Start processing " & sh_source, FinalRow
            If DBG Then Debug.Print UBound(SSArr), UBound(SSArr, 2)
            ReDim OneLine(1 To UBound(SSArr, 2))
            ' Loop through each row of itemlist
            For I = 2 To FinalRow
'****** Rows PROGRESS BAR
                    Me.LabelProgress2.Width = 200 * I / FinalRow
                    'debug info every 100 lines:
                    If I Mod 100 = 0 Then           'print time every 100 lines, debug purpose
                        Debug.Print Format(Timer - myTim, "0.00"), I
                        DoEvents
                    End If
                    ' Decide WHERE to copy based on column Class
                    Column_Txt = SSArr(I, SearchColumn)
                    'New For /Next                                                  'V2
                    For KK = 1 To UBound(HMIArr, 2)                                 '
                        hSh = ItemVal(HMIArr, Column_Txt, KK)                       '
                        If hSh = "" Then                                            '
                            Exit For                                                '
                        End If                                                      '
                    DestSh = "#" & hSh & "_" & Language                             '
                    If ShAvail(ActiveWorkbook, DestSh) Then
                        NextRow = Sheets(DestSh).Cells(Rows.Count, 1).End(xlUp).Row + 1
                        'Copy one line of data
                        For J = 1 To UBound(OneLine)
                            OneLine(J) = SSArr(I, J)
                        Next J
                        'dump to the output sheet
                        Sheets(DestSh).Cells(NextRow, 1).Resize(1, UBound(OneLine)).Value = OneLine
                    Else
                        'Missing sheet??
                        MsgBox ("Worksheet " & DestSh & " seem to be missing; the process will be aborted")
                        GoTo eForm
                        Stop
                    End If
                DoEvents
                Next KK                                                         'V2
            Next I
        Next M
    ' ---------------------------------------------------------------------------------------
eForm:
    
    'Openen voorblad
'    ActiveWorkbook.Sheets("Frontpage").Activate
    Application.ScreenUpdating = True
    Unload Me
Debug.Print Format(Timer - myTim, "0.00"), Now, "Unload UForm"
End Sub



Function ItemVal(ByRef DArr, CellTxt As String, tCount As Long) As String       'V2
Dim I As Long, J As Long, oCount As Long
'
For I = 1 To UBound(DArr)
    For J = 1 To UBound(DArr, 2)
        If DArr(I, J) = "" Then DArr(I, J) = "###"
        If InStr(1, CellTxt & "#", DArr(I, J) & "#", vbTextCompare) > 0 Then
            oCount = oCount + 1
            If oCount = tCount Then
                ItemVal = DArr(1, J)
                Exit Function
            End If
        End If
    Next J
Next I
End Function



Function ShAvail(tWb As Workbook, tSh As String) As Boolean
    On Error Resume Next
        ShAvail = UCase(tWb.Sheets(tSh).Name) = UCase(tSh)
    On Error GoTo 0
'If ShAvail = False Then Stop
End Function

The modifications affect Function ItemVal and a new block in the main Sub UserForm_Activate; these are marked as 'V2 in the above code
Function ShAvail has not been modified.

Try again…