Need Help Merging 3 VBA Scripts into 1

H

Hyperlite

New Member
Joined
Jun 27, 2012
Messages
10
I have 3 versions of a script I run inside VBA in Module1 of an excel sheet dependent on how raw data is received from a customer. The data can be organized in 1 of 3 manners below:

Data Type 1: R1, R2, R3, R4, R5
Data Type 2: R1,R2,R3,R4,R5
Data Type 3: R1 R2 R3 R4 R5

Essentially, the separating factor is a comma and a space, a comma only, or a space only. I have 3 code segments written for each case, but would like to combine all of the codes into 1 for ease of use. Theoretically Type 1 needs to be checked for 1st, then Type 2, then Type 3 as that order should eliminate false positives and formatting errors. I have tried adding an "If" statement to capture this but have been unsuccessful so far.

The part of the code I have been trying to edit is the following, specifically the "arrRef" portion:
Type 1
Code: 
   Do Until RefDesData = ""
      'spilit into the array on comma followed by space
      arrRef = Split(RefDesData.Value, ", ")

Type 2
Code: 
Do Until RefDesData = ""
      'spilit into the array on comma only
      arrRef = Split(RefDesData.Value, ",")

Type 3
Code: 
   Do Until RefDesData = ""
      'spilit into the array on space only
      arrRef = Split(RefDesData.Value, " ")

The codes I have written in entirety will be placed below. For a description of how this code was originally generated and what its use is for, please reference this thread: http://www.mrexcel.com/forum/excel-questions/643373-complex-script-question.html#post3192793

The main difference is I run this script form a module as opposed to the "ThisWorkbook" area of the VBA project as bertie instructed due to having a different code in "ThisWorkbook" to force pasting of values only across the whole sheet.


Here are the codes in entirety:

Type 1 - Comma and Space
Code: 
Option Explicit




Sub Main()
   Dim RefDesData As Range
   Dim PnPData As Worksheet
   Dim arrRef As Variant      'array of references
   Dim i As Long              'loop variable
   Dim strTemp As String
   
   Set RefDesData = Sheets("SortedRefDes").Range("B3")
   Set PnPData = Sheets("PnP")
   
   On Error GoTo errExit
   
   Do Until RefDesData = ""
      'spilit into the array on comma followed by space
      arrRef = Split(RefDesData.Value, ", ")
      
      For i = LBound(arrRef) To UBound(arrRef)
         strTemp = FindRef(PnPData, Trim(arrRef(i)))
         
         'output
         Select Case UCase(strTemp)
            Case "TOP"
               If RefDesData.Offset(, 1).Value = "" Then
                  RefDesData.Offset(, 1).Value = arrRef(i)
               Else
                  RefDesData.Offset(, 1).Value = RefDesData.Offset(, 1).Value & "," & arrRef(i)
               End If
               RefDesData.Offset(, 2).Value = RefDesData.Offset(, 2).Value + 1
               
               
            Case "T"
               If RefDesData.Offset(, 1).Value = "" Then
                  RefDesData.Offset(, 1).Value = arrRef(i)
               Else
                  RefDesData.Offset(, 1).Value = RefDesData.Offset(, 1).Value & "," & arrRef(i)
               End If
               RefDesData.Offset(, 2).Value = RefDesData.Offset(, 2).Value + 1
               
               
            Case "BOTTOM"
               If RefDesData.Offset(, 3).Value = "" Then
                  RefDesData.Offset(, 3).Value = arrRef(i)
               Else
                  RefDesData.Offset(, 3).Value = RefDesData.Offset(, 3).Value & "," & arrRef(i)
               End If
               RefDesData.Offset(, 4).Value = RefDesData.Offset(, 4).Value + 1
            
            
            Case "B"
               If RefDesData.Offset(, 3).Value = "" Then
                  RefDesData.Offset(, 3).Value = arrRef(i)
               Else
                  RefDesData.Offset(, 3).Value = RefDesData.Offset(, 3).Value & "," & arrRef(i)
               End If
               RefDesData.Offset(, 4).Value = RefDesData.Offset(, 4).Value + 1
            
            Case Else
               'not found
               'code for ref not found goes here
         End Select
         
         'calculate total
         RefDesData.Offset(, 5).Value = _
            RefDesData.Offset(, 2).Value + RefDesData.Offset(, 4).Value
      Next i
      
      'next row
      Set RefDesData = RefDesData.Offset(1, 0)
   Loop
   
errExit:
   'tidy up and release memory
   Set RefDesData = Nothing
   Set PnPData = Nothing
   
End Sub








Private Function FindRef(ByVal ws As Worksheet, _
                         ByVal ref As String) As String
   Dim rngFound As Range
   
   On Error Resume Next
      With ws
         Set rngFound = .Columns(1).Find(What:=ref, _
                        After:=.Cells(1, 1), _
                        LookIn:=xlValues, _
                        LookAt:=xlPart, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False, _
                        SearchFormat:=False)
         On Error GoTo 0
      End With
      
   If Not rngFound Is Nothing Then
      FindRef = rngFound.Offset(, 1).Value
   Else
      FindRef = ""
   End If
End Function

Type 2 - Comma Only
Code: 
Option Explicit




Sub Main()
   Dim RefDesData As Range
   Dim PnPData As Worksheet
   Dim arrRef As Variant      'array of references
   Dim i As Long              'loop variable
   Dim strTemp As String
   
   Set RefDesData = Sheets("SortedRefDes").Range("B3")
   Set PnPData = Sheets("PnP")
   
   On Error GoTo errExit
   
   Do Until RefDesData = ""
      'spilit into the array on comma only
      arrRef = Split(RefDesData.Value, ",")
      
      For i = LBound(arrRef) To UBound(arrRef)
         strTemp = FindRef(PnPData, Trim(arrRef(i)))
         
         'output
         Select Case UCase(strTemp)
            Case "TOP"
               If RefDesData.Offset(, 1).Value = "" Then
                  RefDesData.Offset(, 1).Value = arrRef(i)
               Else
                  RefDesData.Offset(, 1).Value = RefDesData.Offset(, 1).Value & "," & arrRef(i)
               End If
               RefDesData.Offset(, 2).Value = RefDesData.Offset(, 2).Value + 1
               
               
            Case "T"
               If RefDesData.Offset(, 1).Value = "" Then
                  RefDesData.Offset(, 1).Value = arrRef(i)
               Else
                  RefDesData.Offset(, 1).Value = RefDesData.Offset(, 1).Value & "," & arrRef(i)
               End If
               RefDesData.Offset(, 2).Value = RefDesData.Offset(, 2).Value + 1
               
               
            Case "BOTTOM"
               If RefDesData.Offset(, 3).Value = "" Then
                  RefDesData.Offset(, 3).Value = arrRef(i)
               Else
                  RefDesData.Offset(, 3).Value = RefDesData.Offset(, 3).Value & "," & arrRef(i)
               End If
               RefDesData.Offset(, 4).Value = RefDesData.Offset(, 4).Value + 1
            
            
            Case "B"
               If RefDesData.Offset(, 3).Value = "" Then
                  RefDesData.Offset(, 3).Value = arrRef(i)
               Else
                  RefDesData.Offset(, 3).Value = RefDesData.Offset(, 3).Value & "," & arrRef(i)
               End If
               RefDesData.Offset(, 4).Value = RefDesData.Offset(, 4).Value + 1
            
            Case Else
               'not found
               'code for ref not found goes here
         End Select
         
         'calculate total
         RefDesData.Offset(, 5).Value = _
            RefDesData.Offset(, 2).Value + RefDesData.Offset(, 4).Value
      Next i
      
      'next row
      Set RefDesData = RefDesData.Offset(1, 0)
   Loop
   
errExit:
   'tidy up and release memory
   Set RefDesData = Nothing
   Set PnPData = Nothing
   
End Sub








Private Function FindRef(ByVal ws As Worksheet, _
                         ByVal ref As String) As String
   Dim rngFound As Range
   
   On Error Resume Next
      With ws
         Set rngFound = .Columns(1).Find(What:=ref, _
                        After:=.Cells(1, 1), _
                        LookIn:=xlValues, _
                        LookAt:=xlPart, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False, _
                        SearchFormat:=False)
         On Error GoTo 0
      End With
      
   If Not rngFound Is Nothing Then
      FindRef = rngFound.Offset(, 1).Value
   Else
      FindRef = ""
   End If
End Function

Type 3 - Space Only
Code: 
Option Explicit




Sub Main()
   Dim RefDesData As Range
   Dim PnPData As Worksheet
   Dim arrRef As Variant      'array of references
   Dim i As Long              'loop variable
   Dim strTemp As String
   
   Set RefDesData = Sheets("SortedRefDes").Range("B3")
   Set PnPData = Sheets("PnP")
   
   On Error GoTo errExit
   
   Do Until RefDesData = ""
      'spilit into the array on space only
      arrRef = Split(RefDesData.Value, " ")
      
      For i = LBound(arrRef) To UBound(arrRef)
         strTemp = FindRef(PnPData, Trim(arrRef(i)))
         
         'output
         Select Case UCase(strTemp)
            Case "TOP"
               If RefDesData.Offset(, 1).Value = "" Then
                  RefDesData.Offset(, 1).Value = arrRef(i)
               Else
                  RefDesData.Offset(, 1).Value = RefDesData.Offset(, 1).Value & "," & arrRef(i)
               End If
               RefDesData.Offset(, 2).Value = RefDesData.Offset(, 2).Value + 1
               
               
            Case "T"
               If RefDesData.Offset(, 1).Value = "" Then
                  RefDesData.Offset(, 1).Value = arrRef(i)
               Else
                  RefDesData.Offset(, 1).Value = RefDesData.Offset(, 1).Value & "," & arrRef(i)
               End If
               RefDesData.Offset(, 2).Value = RefDesData.Offset(, 2).Value + 1
               
               
            Case "BOTTOM"
               If RefDesData.Offset(, 3).Value = "" Then
                  RefDesData.Offset(, 3).Value = arrRef(i)
               Else
                  RefDesData.Offset(, 3).Value = RefDesData.Offset(, 3).Value & "," & arrRef(i)
               End If
               RefDesData.Offset(, 4).Value = RefDesData.Offset(, 4).Value + 1
            
            
            Case "B"
               If RefDesData.Offset(, 3).Value = "" Then
                  RefDesData.Offset(, 3).Value = arrRef(i)
               Else
                  RefDesData.Offset(, 3).Value = RefDesData.Offset(, 3).Value & "," & arrRef(i)
               End If
               RefDesData.Offset(, 4).Value = RefDesData.Offset(, 4).Value + 1
            
            Case Else
               'not found
               'code for ref not found goes here
         End Select
         
         'calculate total
         RefDesData.Offset(, 5).Value = _
            RefDesData.Offset(, 2).Value + RefDesData.Offset(, 4).Value
      Next i
      
      'next row
      Set RefDesData = RefDesData.Offset(1, 0)
   Loop
   
errExit:
   'tidy up and release memory
   Set RefDesData = Nothing
   Set PnPData = Nothing
   
End Sub








Private Function FindRef(ByVal ws As Worksheet, _
                         ByVal ref As String) As String
   Dim rngFound As Range
   
   On Error Resume Next
      With ws
         Set rngFound = .Columns(1).Find(What:=ref, _
                        After:=.Cells(1, 1), _
                        LookIn:=xlValues, _
                        LookAt:=xlPart, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False, _
                        SearchFormat:=False)
         On Error GoTo 0
      End With
      
   If Not rngFound Is Nothing Then
      FindRef = rngFound.Offset(, 1).Value
   Else
      FindRef = ""
   End If
End Function


I am by no means a VBA expert of any kind. I have some programming experience and can pick things up relatively well when seeing examples, but this one I am really needing some help on.

Please feel free to ask any questions you might have and I will try to answer to the best of my ability.

Thanks in advance.





I am unsure if this will be needed info, but just so the info is here, the code I have in "ThisWorkbook" of the same excel document is from this thread: http://www.mrexcel.com/forum/excel-questions/230718-force-paste-special-values-2.html
Code: 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)


    Dim UndoString As String
    Dim srce As Range


    On Error GoTo err_handler


    UndoString = Application.CommandBars("Standard").Controls("&Undo").List(1)
    
    If Left(UndoString, 5) <> "Paste" And UndoString <> "Auto Fill" Then
        
        Exit Sub
        
    End If
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Undo
            
            
    If UndoString = "Auto Fill" Then
        
        Set srce = Selection
        
        srce.Copy
        
        Target.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
                    
        Application.SendKeys "{ESC}"


        Union(Target, srce).Select
        
    Else
    
        Target.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
                    
    End If
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True


    Exit Sub


err_handler:


    Application.ScreenUpdating = True
    Application.EnableEvents = True


End Sub
 
Last edited:

Excel Facts

Can a formula spear through sheets?
Use =SUM(January:December!E7) to sum E7 on all of the sheets from January through December
Sort by date Sort by votes
you don't really need three separate codes. just fix the data before splitting it:

Code: 
dim strDesData as String
.....
Do Until RefDesData = ""
strDesData = refDesData.Value
strDesData = replace(strDesData ," ",",")
strDesData = replace(strDesData ,",,",",")
'split into the array on comma only
arrRef = Split(strDesData , ",")
...
 
Upvote 0
bobsan42 said:
you don't really need three separate codes. just fix the data before splitting it:

Code: 
dim strDesData as String
.....
Do Until RefDesData = ""
strDesData = refDesData.Value
strDesData = replace(strDesData ," ",",")
strDesData = replace(strDesData ,",,",",")
'split into the array on comma only
arrRef = Split(strDesData , ",")
...
Click to expand...

Thank you for the suggestion.

I incorporated your code and ran the script over some Type 3 data (space only as the differentiator). The code no longer works on a set of data. For example:

If only R1 is listed on a line, it will correctly cross reference and re-type that value out.
If R1 R2 R3 R4 R5 or any combination of multiple entries are listed it will bypass this line completely and places nothing in the correlating cell. They are left blank.

Here is the code I merged with your suggestion:
Code: 
Option Explicit




Sub Main()
   Dim RefDesData As Range
   Dim StrDesData as String
   Dim PnPData As Worksheet
   Dim arrRef As Variant      'array of references
   Dim i As Long              'loop variable
   Dim strTemp As String
   
   Set RefDesData = Sheets("SortedRefDes").Range("B3")
   Set PnPData = Sheets("PnP")
   
   On Error GoTo errExit
   
   Do Until RefDesData = ""
      StrDesData = refDesData.Value
      StrDesData = replace(StrDesData ," ",",")
      StrDesData = replace(StrDesData ,",,",",")
      'spilit into the array on comma only
      arrRef = Split(RefDesData.Value, ",")
      
      For i = LBound(arrRef) To UBound(arrRef)
         strTemp = FindRef(PnPData, Trim(arrRef(i)))
         
         'output
         Select Case UCase(strTemp)
            Case "TOP"
               If RefDesData.Offset(, 1).Value = "" Then
                  RefDesData.Offset(, 1).Value = arrRef(i)
               Else
                  RefDesData.Offset(, 1).Value = RefDesData.Offset(, 1).Value & "," & arrRef(i)
               End If
               RefDesData.Offset(, 2).Value = RefDesData.Offset(, 2).Value + 1
               
               
            Case "T"
               If RefDesData.Offset(, 1).Value = "" Then
                  RefDesData.Offset(, 1).Value = arrRef(i)
               Else
                  RefDesData.Offset(, 1).Value = RefDesData.Offset(, 1).Value & "," & arrRef(i)
               End If
               RefDesData.Offset(, 2).Value = RefDesData.Offset(, 2).Value + 1
               
               
            Case "BOTTOM"
               If RefDesData.Offset(, 3).Value = "" Then
                  RefDesData.Offset(, 3).Value = arrRef(i)
               Else
                  RefDesData.Offset(, 3).Value = RefDesData.Offset(, 3).Value & "," & arrRef(i)
               End If
               RefDesData.Offset(, 4).Value = RefDesData.Offset(, 4).Value + 1
            
            
            Case "B"
               If RefDesData.Offset(, 3).Value = "" Then
                  RefDesData.Offset(, 3).Value = arrRef(i)
               Else
                  RefDesData.Offset(, 3).Value = RefDesData.Offset(, 3).Value & "," & arrRef(i)
               End If
               RefDesData.Offset(, 4).Value = RefDesData.Offset(, 4).Value + 1
            
            Case Else
               'not found
               'code for ref not found goes here
         End Select
         
         'calculate total
         RefDesData.Offset(, 5).Value = _
            RefDesData.Offset(, 2).Value + RefDesData.Offset(, 4).Value
      Next i
      
      'next row
      Set RefDesData = RefDesData.Offset(1, 0)
   Loop
   
errExit:
   'tidy up and release memory
   Set RefDesData = Nothing
   Set PnPData = Nothing
   
End Sub








Private Function FindRef(ByVal ws As Worksheet, _
                         ByVal ref As String) As String
   Dim rngFound As Range
   
   On Error Resume Next
      With ws
         Set rngFound = .Columns(1).Find(What:=ref, _
                        After:=.Cells(1, 1), _
                        LookIn:=xlValues, _
                        LookAt:=xlPart, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False, _
                        SearchFormat:=False)
         On Error GoTo 0
      End With
      
   If Not rngFound Is Nothing Then
      FindRef = rngFound.Offset(, 1).Value
   Else
      FindRef = ""
   End If
End Function
 
Upvote 0
sorry - I didn't check your code completely. I just wrote the way I normally would.
Let's dump the string variable then.
Code: 
 [COLOR=#ff0000] refDesData= replace(refDesData," ",",")
  refDesData= replace(refDesData,",,",",")[/COLOR]
Do Until RefDesData = ""
  'split into the array on comma only
  arrRef = Split(refDesData, ",")
This is the smallest possible change to your original code - just add the two lines in red BEFORE the Do Until.
 
Upvote 0
bobsan42 said:
sorry - I didn't check your code completely. I just wrote the way I normally would.
Let's dump the string variable then.
Code: 
 [COLOR=#ff0000] refDesData= replace(refDesData," ",",")
  refDesData= replace(refDesData,",,",",")[/COLOR]
Do Until RefDesData = ""
  'split into the array on comma only
  arrRef = Split(refDesData, ",")
This is the smallest possible change to your original code - just add the two lines in red BEFORE the Do Until.
Click to expand...

I attempted that as well and it produced the same result as the previous suggestion.

I found a webpage that describes replacing strings in a range at: https://msdn.microsoft.com/en-us/library/office/ff194086.aspx?f=255&MSPPError=-2147217396

However, I added the following:
Code: 
...
   On Error GoTo errExit
   
   RefDesData = RefDesData.replace(" ,", ",")
   RefDesData = RefDesData.replace(" ", ",")
   RefDesData = RefDesData.replace(",,", ",")


   Do Until RefDesData = ""
...

When adding this, I am getting the same result except I am also getting the boolean "TRUE" return as well, which isn't a desirable effect either.
 
Upvote 0
I am still attempting to solve this. It seems like I need to be able to search for and replace specific strings inside of a range of data that also contains longer strings in each cell. This should probably be done before the script starts running.
 
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Solved
Help with VBA Code in Excel
Replies
2
Views
262
tixarah
T
S
  • Question Question
Help with combining 2 macros into 1
Replies
8
Views
246
MARK858
MARK858
J
  • Question Question
Userform inconsistent responses
Replies
1
Views
167
Candyman8019
C
K
  • Question Question
Reverse Engineer Outlook Macro since New Outlook does not allow Macros
Replies
1
Views
346
John_w
J
D
  • Question Question
Copy cell $G$1 (value only) 1 cell to the right of the checkbox when clicked
Replies
1
Views
170
Artik
Artik

Forum statistics

Threads
1,223,220
Messages
6,170,807
Members
452,354
Latest member
yuzha

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top