If you find any post useful then, please do share with others. Thanks!

Popular Posts

Contact

Email me

Need help and that also free? I like to learn this way, in case of any question or for a small task, please feel free to email me with details and example data, if required.

Wednesday, June 14, 2023

Excel VBA Code/Mcro: Combine Text from multiple rows into one for respective grouping

Here's a VBA code that combines the descriptions for each Team (Column A is Team and Column B Description) and creates a list of unique departments with their combined descriptions in the result sheet: 


Sub CombineDescriptionsByDepartment()

    Dim dataSheet As Worksheet

    Dim resultSheet As Worksheet

    Dim dataRange As Range

    Dim departmentColumn As Range

    Dim descriptionColumn As Range

    Dim departments As Variant

    Dim descriptions As Variant

    Dim department As Variant

    Dim description As Variant

    Dim combinedDescriptions As Object

    Dim rowIndex As Long

    Dim resultTable As Range

    Dim resultRowIndex As Long

    

    ' Set the data sheet and result sheet references

    Set dataSheet = ThisWorkbook.Sheets("Sheet1") ' Replace with your actual data sheet name

    Set resultSheet = ThisWorkbook.Sheets("Sheet2") ' Replace with your actual result sheet name

    

    ' Set the data range references

    Set dataRange = dataSheet.Range("A1:B" & Selection.Rows.Count) ' Adjust the range as per your data

    

    ' Get the department and description columns from the data range

    Set departmentColumn = dataRange.Columns(1)

    Set descriptionColumn = dataRange.Columns(2)

    

    ' Get unique departments and descriptions from the columns

    departments = departmentColumn.Value

    descriptions = descriptionColumn.Value

    

    ' Create a dictionary to store combined descriptions for each department

    Set combinedDescriptions = CreateObject("Scripting.Dictionary")

    

    ' Loop through the data and combine descriptions for each department

    For rowIndex = 2 To UBound(departments)

        department = departments(rowIndex, 1)

        description = descriptions(rowIndex, 1)

        

        If Not combinedDescriptions.Exists(department) Then

            combinedDescriptions(department) = description

        Else

            combinedDescriptions(department) = combinedDescriptions(department) & " " & description

        End If

    Next rowIndex

    

    ' Clear the result sheet

    resultSheet.UsedRange.Clear

    

    ' Write the results to the result sheet

    resultRowIndex = 1

    For Each department In combinedDescriptions.keys

        Set resultTable = resultSheet.Range("A" & resultRowIndex)

        

        ' Write the department name

        resultTable.Value = department

        

        ' Write the combined description

        resultTable.Offset(0, 1).Value = combinedDescriptions(department)

        

        ' Move to the next result row

        resultRowIndex = resultRowIndex + 1

    Next department

    

    MsgBox "Description combination completed."

    

End Sub


Sunday, May 28, 2023

Excel VBA/Macro to fetch consecutive Duplicate words in multiple cells of a column selection

 Select the data/column and run the Macro, It will fetch the consecutive duplicate words and add them in the next column for each cell. The word with length more than 2 included and another exception is that they shouldn't be ending with comma.

Sub FetchConsecutiveDuplicates()
    Dim rng As Range
    Dim cell As Range
    Dim words() As String
    Dim i As Long
    Dim startPos As Long
    Dim endPos As Long
    Dim duplicates As String
    
    ' Select the column where you want to check for consecutive duplicates
    Set rng = Selection

    For Each cell In rng
        If Not IsEmpty(cell.Value) Then
            words = Split(cell.Value, " ")
            startPos = 1
            duplicates = ""
            
            For i = LBound(words) + 1 To UBound(words)
                If LCase(words(i)) = LCase(words(i - 1)) Then ' Compare words case-insensitively
                    endPos = InStr(startPos, cell.Value, words(i), vbTextCompare)
                    
                    ' Check if the word meets the criteria
                    If Len(words(i)) >= 3 And Right(words(i), 1) <> "," Then
                        ' Append the duplicate word to the duplicates string
                        duplicates = duplicates & words(i) & " "
                    End If
                    
                    startPos = endPos + Len(words(i)) + 1 ' Move the starting position to the next word
                End If
            Next i
            
            ' Paste the consecutive duplicate words in the next column's cell
            If duplicates <> "" Then
                cell.Offset(0, 1).Value = Trim(duplicates)
            End If
        End If
    Next cell
End Sub

MS Excel Trick: Copy-Paste in Filtered/Visible Cells Only (Urdu/Hindi Tu...

Monday, April 3, 2023

Excel VBA: save a macro-enabled Excel file as a non-macro file

 In this code, you need to replace "C:\Users\UserName\Documents\NewFile.xlsx" with the file path and name where you want to save the new file. The xlOpenXMLWorkbook file format argument specifies that the file should be saved as a non-macro-enabled file.


Before saving the file, the code disables macros using the EnableReferences property of the VBE project. After saving the file, it enables macros again. This is important because if the file is saved with macros enabled, it will still be a macro-enabled file even if the file extension is changed.


Sub SaveAsNonMacroFile()

    'Set the file path and name for the new file

    Dim NewFilePath As String

    NewFilePath = "C:\Users\UserName\Documents\NewFile.xlsx"

    

    'Disable macros

    ThisWorkbook.VBProject.VBE.ActiveVBProject.References.EnableReferences = False

    

    'Save the file as a non-macro-enabled file

    ActiveWorkbook.SaveAs Filename:=NewFilePath, FileFormat:=xlOpenXMLWorkbook

    

    'Enable macros

    ThisWorkbook.VBProject.VBE.ActiveVBProject.References.EnableReferences = True

End Sub