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
    Dim cleaned As String
    
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Set wb = ThisWorkbook
    
    ' Check if sheet exists
    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: Read bulk data from text file
    inputData = GetTextFromFile()
    If Trim(inputData) = "" Then
        MsgBox "No data found or file selection cancelled.", vbExclamation
        GoTo CleanExit
    End If
    
    ' 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 results 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 for matches
    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))
                    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


' ===== Helper Function: Check if Sheet Exists =====
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


' ===== Helper Function: Read Text File Data =====
Private Function GetTextFromFile() As String
    Dim filePath As String
    Dim fileNo As Integer
    Dim fileContent As String
    Dim lineText As String
    
    ' Open file dialog
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Select Bulk Data Text File"
        .Filters.Clear
        .Filters.Add "Text Files", "*.txt"
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Function ' User cancelled
        filePath = .SelectedItems(1)
    End With
    
    ' Read file content
    fileNo = FreeFile
    Open filePath For Input As #fileNo
    Do Until EOF(fileNo)
        Line Input #fileNo, lineText
        fileContent = fileContent & lineText & vbCrLf
    Loop
    Close #fileNo
    
    GetTextFromFile = fileContent
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

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