fixed 😃😃

Option Explicit

Sub Select_Bulk_Data_InputBox_Final3()

    Dim sheetName As String
    sheetName = "Data 1" ' <<-- Change the sheet name here only (exact name)
    
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rng As Range
    Dim inputData As String
    Dim arrInput As Variant
    Dim searchValues() As String
    Dim cleanedValues() As String
    Dim removeChars As String
    Dim arrRemove As Variant
    Dim removeProvided As Boolean
    Dim colInput As String
    Dim arrCols As Variant
    Dim validCols As Collection
    Dim resultSheet As Worksheet
    Dim i As Long, j As Long, k As Long
    Dim cell As Range
    Dim cellValue As String
    Dim lastCol As Long
    Dim foundCount As Long
    Dim isFound As Boolean
    Dim msgText As String
    Dim cleaned As String
    
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Set wb = ThisWorkbook
    
    ' Check sheet existence
    If Not SheetExists(sheetName, wb) Then
        MsgBox "Sheet named '" & sheetName & "' not found. Change the sheetName at the top of the macro and try again.", vbExclamation, "Missing Sheet"
        GoTo CleanExit
    End If
    
    Set ws = wb.Worksheets(sheetName)
    Set rng = ws.UsedRange
    If rng Is Nothing Then
        MsgBox "No used range found on sheet '" & sheetName & "'.", vbExclamation, "Empty Sheet"
        GoTo CleanExit
    End If
    lastCol = rng.Columns.Count
    
    ' Step 1: Bulk input (Unlimited InputBox)
    inputData = GetLargeTextInput("Paste your bulk data here (comma, space, tab, or line-break separated):", "Bulk Data Select")
    If Trim(inputData) = "" Then GoTo CleanExit
    
    ' Normalize separators
    inputData = Replace(inputData, vbTab, ",")
    inputData = Replace(inputData, vbCrLf, ",")
    inputData = Replace(inputData, vbLf, ",")
    inputData = Replace(inputData, " ", ",")
    Do While InStr(inputData, ",,") > 0
        inputData = Replace(inputData, ",,", ",")
    Loop
    If Left(inputData, 1) = "," Then inputData = Mid(inputData, 2)
    If Right(inputData, 1) = "," Then inputData = Left(inputData, Len(inputData) - 1)
    
    arrInput = Split(inputData, ",")
    ReDim searchValues(LBound(arrInput) To UBound(arrInput))
    For i = LBound(arrInput) To UBound(arrInput)
        searchValues(i) = Trim(CStr(arrInput(i)))
    Next i
    
    ' Step 2: Substrings to remove
    removeChars = InputBox("Enter substrings to remove if present (comma-separated, e.g. _,GL,AD) or leave blank:", "Remove Substrings")
    If Trim(removeChars) <> "" Then
        arrRemove = Split(removeChars, ",")
        removeProvided = True
        For i = LBound(arrRemove) To UBound(arrRemove)
            arrRemove(i) = Trim(CStr(arrRemove(i)))
        Next i
    Else
        removeProvided = False
        ReDim arrRemove(0 To -1)
    End If
    
    ' Step 3: Cleaned values
    ReDim cleanedValues(LBound(searchValues) To UBound(searchValues))
    For i = LBound(searchValues) To UBound(searchValues)
        cleaned = searchValues(i)
        If removeProvided Then
            For k = LBound(arrRemove) To UBound(arrRemove)
                If arrRemove(k) <> "" Then cleaned = Replace(cleaned, arrRemove(k), "")
            Next k
        End If
        cleanedValues(i) = Trim(cleaned)
    Next i
    
    ' Step 4: Columns to copy
    colInput = InputBox("Enter the column numbers you want to copy from " & sheetName & " (comma-separated, e.g., 1,3,6):", "Select Columns")
    If Trim(colInput) = "" Then GoTo CleanExit
    
    arrCols = Split(colInput, ",")
    Set validCols = New Collection
    For i = LBound(arrCols) To UBound(arrCols)
        Dim cnum As Long
        cnum = Val(Trim(arrCols(i)))
        If cnum > 0 And cnum <= lastCol Then validCols.Add cnum
    Next i
    If validCols.Count = 0 Then
        MsgBox "No valid columns selected or columns out of range 1 to " & lastCol & ".", vbExclamation, "Invalid Columns"
        GoTo CleanExit
    End If
    
    ' Step 5: Create single result sheet
    On Error Resume Next
    Application.DisplayAlerts = False
    If SheetExists("Results", wb) Then wb.Worksheets("Results").Delete
    Application.DisplayAlerts = True
    On Error GoTo ErrHandler
    
    Set resultSheet = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
    resultSheet.Name = "Results"
    
    ' Headers
    resultSheet.Cells(1, 1).Value = "Original Value"
    resultSheet.Cells(1, 2).Value = "Cleaned Value"
    For j = 1 To validCols.Count
        resultSheet.Cells(1, 2 + j).Value = "Col" & validCols(j)
    Next j
    
    foundCount = 1
    
    ' Step 6: Search (substring match)
    For i = LBound(cleanedValues) To UBound(cleanedValues)
        foundCount = foundCount + 1
        isFound = False
        If cleanedValues(i) <> "" Then
            For Each cell In rng
                If Len(Trim(CStr(cell.Value))) > 0 Then
                    cellValue = Trim(CStr(cell.Value))
                    ' Substring match
                    If InStr(1, cellValue, cleanedValues(i), vbTextCompare) > 0 Then
                        isFound = True
                        resultSheet.Cells(foundCount, 1).Value = searchValues(i)
                        resultSheet.Cells(foundCount, 2).Value = cleanedValues(i)
                        For j = 1 To validCols.Count
                            On Error Resume Next
                            resultSheet.Cells(foundCount, 2 + j).Value = ws.Cells(cell.Row, validCols(j)).Value
                            On Error GoTo ErrHandler
                        Next j
                        Exit For
                    End If
                End If
            Next cell
        End If
        
        If Not isFound Then
            resultSheet.Cells(foundCount, 1).Value = searchValues(i)
            resultSheet.Cells(foundCount, 2).Value = cleanedValues(i)
        End If
    Next i
    
    resultSheet.Columns.AutoFit
    
    msgText = "Bulk search completed." & vbCrLf
    msgText = msgText & "Processed: " & (UBound(searchValues) - LBound(searchValues) + 1)
    MsgBox msgText, vbInformation, "Search Complete"
    
CleanExit:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Exit Sub
    
ErrHandler:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    MsgBox "Error " & Err.Number & ": " & Err.Description, vbExclamation, "Error"
End Sub

Private Function SheetExists(sName As String, wb As Workbook) As Boolean
    Dim tmp As Worksheet
    On Error Resume Next
    Set tmp = wb.Worksheets(sName)
    SheetExists = Not tmp Is Nothing
    On Error GoTo 0
End Function

' -----------------------
' Custom Unlimited InputBox
' -----------------------
Private Function GetLargeTextInput(prompt As String, title As String) As String
    Dim objForm As Object
    Dim txtInput As Object
    Dim btnOK As Object
    Dim btnCancel As Object
    Dim answer As String
    Dim cancelled As Boolean
    
    Set objForm = CreateObject("Forms.UserForm.1")
    objForm.Caption = title
    objForm.Width = 400
    objForm.Height = 300
    
    Set txtInput = objForm.Controls.Add("Forms.TextBox.1")
    With txtInput
        .Multiline = True
        .WordWrap = True
        .ScrollBars = 2
        .Left = 10
        .Top = 20
        .Width = 370
        .Height = 200
        .Text = ""
    End With
    
    Set btnOK = objForm.Controls.Add("Forms.CommandButton.1")
    btnOK.Caption = "OK"
    btnOK.Left = 220
    btnOK.Top = 230
    btnOK.Width = 70
    btnOK.Height = 25
    
    Set btnCancel = objForm.Controls.Add("Forms.CommandButton.1")
    btnCancel.Caption = "Cancel"
    btnCancel.Left = 300
    btnCancel.Top = 230
    btnCancel.Width = 70
    btnCancel.Height = 25
    
    ' Event Handling
    With objForm.CodeModule
        .InsertLines .CountOfLines + 1, _
        "Private Sub CommandButton1_Click()" & vbCrLf & _
        "   Me.Hide" & vbCrLf & _
        "End Sub"
        .InsertLines .CountOfLines + 1, _
        "Private Sub CommandButton2_Click()" & vbCrLf & _
        "   Me.Tag = ""CANCEL""" & vbCrLf & _
        "   Me.Hide" & vbCrLf & _
        "End Sub"
    End With
    
    objForm.Show
    If objForm.Tag <> "CANCEL" Then
        answer = txtInput.Text
    Else
        answer = ""
    End If
    Unload objForm
    GetLargeTextInput = answer
End Function

Comments

Post a Comment

Popular posts from this blog

fixed

Sub Select_Bulk_Data_InputBox_Final2()     Dim sheetName As String     sheetName = "Data 1" ' <<-- Change the sheet name here only (exact name)     Dim wb As Workbook     Dim ws As Worksheet     Dim rng As Range     Dim inputData As String     Dim arrInput As Variant     Dim searchValues() As String     Dim cleanedValues() As String     Dim removeChars As String     Dim arrRemove As Variant     Dim removeProvided As Boolean     Dim colInput As String     Dim arrCols As Variant     Dim validCols As Collection     Dim foundSheet As Worksheet, notFoundSheet As Worksheet     Dim i As Long, j As Long, k As Long     Dim cell As Range     Dim cellValue As String     Dim lastCol As Long     Dim foundCount As Long, notFoundCount As Long     Dim isFound As Boolean   ...
Read more

fixed 😃😃😃

Sub Select_Bulk_Data_InputBox_Final3()     Dim sheetName As String     sheetName = "Data 1" ' <<-- Change the sheet name here only (exact name)          Dim wb As Workbook     Dim ws As Worksheet     Dim rng As Range     Dim inputData As String     Dim arrInput As Variant     Dim searchValues() As String     Dim cleanedValues() As String     Dim removeChars As String     Dim arrRemove As Variant     Dim removeProvided As Boolean     Dim colInput As String     Dim arrCols As Variant     Dim validCols As Collection     Dim resultSheet As Worksheet     Dim i As Long, j As Long, k As Long     Dim cell As Range     Dim cellValue As String     Dim lastCol As Long     Dim foundCount As Long     Dim isFound As Boolean     Dim msgText As String ...
Read more

babyGirl

 Sub Select_Bulk_Data_InputBox()     Dim ws As Worksheet     Dim rng As Range     Dim cell As Range     Dim inputData As String     Dim searchValues() As String     Dim i As Long, j As Long     Dim cellValue As String     Dim selRange As Range     Dim lastCol As Long     Dim searchText As String     Dim colInput As String     Dim colNumbers() As String     Dim colNum As Long     Dim validCols As Collection     Dim removeChars As String     Dim removeList() As String     Dim k As Long     ' Sheet reference     Set ws = ThisWorkbook.Sheets("Data 1")     Set rng = ws.UsedRange          ' Clear previous selection     ws.Cells(1, 1).Select          ' Step 1: Get bulk data from user     inputData = InputBox("Paste your bul...
Read more