Create Stunning Firework Animations in Excel with VBA!, Urdu/Hindi

Sub FireworkAnimation()

    Dim fireworkShape As Shape

    Dim centerX As Single, centerY As Single

    Dim angle As Single

    Dim speedX As Single, speedY As Single

    Dim steps As Integer

    Dim colorR As Integer, colorG As Integer, colorB As Integer

    Dim i As Integer, j As Integer

    Dim particleCount As Integer

    Dim particles() As Shape

    Dim speedsX() As Single, speedsY() As Single

    Dim ballSize As Single

    

    ' Set the active sheet as the canvas

    Dim canvas As Worksheet

    Set canvas = ActiveSheet

    

    ' Clear any existing shapes

    On Error Resume Next

    canvas.Shapes.SelectAll

    Selection.Delete

    On Error GoTo 0

    

    ' Firework center position

    centerX = 400

    centerY = 300

    

    ' Number of particles per firework

    particleCount = 20

    

    ' Particle attributes

    steps = 50

    ballSize = 15 ' Increased size for the particles

    

    ' Initialize particle and speed arrays

    ReDim particles(1 To particleCount)

    ReDim speedsX(1 To particleCount)

    ReDim speedsY(1 To particleCount)

    

    ' Randomize the color for all particles

    colorR = Int(Rnd() * 255)

    colorG = Int(Rnd() * 255)

    colorB = Int(Rnd() * 255)

    

    ' Create particles and their corresponding speeds

    For i = 1 To particleCount

        angle = Rnd() * 2 * 3.14159

        speedX = Cos(angle) * (Rnd() * 10 + 5)

        speedY = Sin(angle) * (Rnd() * 10 + 5)

        

        ' Add a shape (circle) for each particle

        Set fireworkShape = canvas.Shapes.AddShape(msoShapeOval, centerX, centerY, ballSize, ballSize)

        fireworkShape.Fill.ForeColor.RGB = RGB(colorR, colorG, colorB)

        fireworkShape.Line.Visible = msoFalse

        

        ' Store the shape and its speeds in the arrays

        Set particles(i) = fireworkShape

        speedsX(i) = speedX

        speedsY(i) = speedY

    Next i

    

    ' Animate all particles simultaneously

    For j = 1 To steps

        For i = 1 To particleCount

            With particles(i)

                .Left = .Left + speedsX(i)

                .Top = .Top + speedsY(i)

                .Fill.Transparency = j / steps ' Gradually fade out

            End With

        Next i

        DoEvents

    Next j

    

    ' Remove all shapes after animation

    For i = 1 To particleCount

        particles(i).Delete

    Next i

End Sub

Complete Management Tool for Atta Chakki | Excel Software for Sales, Inv...

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

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...