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

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

Number Guessing Game, Using Excel VBA

In this game, the player has to guess a randomly generated secret number between 1 and 100. The player has 10 guesses to correctly guess the number. After each guess, the player is told whether the secret number is higher or lower than their guess. If the player correctly guesses the secret number, they win the game. If the player uses up all their guesses without correctly guessing the secret number, they lose the game.

Note: This game uses the Rnd function to generate a random number. However, the Rnd function is based on the system clock, so if you want to generate truly random numbers, you may need to use a more advanced random number generator.

Sub NumberGuessingGame()

    Dim SecretNumber As Integer

    Dim Guess As Integer

    Dim GuessesRemaining As Integer

    

    SecretNumber = Int((100 - 1 + 1) * Rnd + 1) 'generate a random number between 1 and 100

    GuessesRemaining = 10 'set the number of guesses

    

    Do While GuessesRemaining > 0

        Guess = InputBox("Guess the secret number between 1 and 100." & vbNewLine & "You have " & GuessesRemaining & " guesses remaining.", "Number Guessing Game")

        If Guess = SecretNumber Then

            MsgBox "Congratulations! You guessed the secret number in " & (10 - GuessesRemaining + 1) & " guesses."

            Exit Sub

        ElseIf Guess < SecretNumber Then

            MsgBox "The secret number is higher than your guess."

        ElseIf Guess > SecretNumber Then

            MsgBox "The secret number is lower than your guess."

        End If

        GuessesRemaining = GuessesRemaining - 1

    Loop

    

    MsgBox "Game over. The secret number was " & SecretNumber & "."

End Sub

Analysis ToolPak; Excel Add In for Statistical Analysis (Descriptive Statistics)

The Analysis ToolPak is an add-in for Microsoft Excel that provides additional functionality for data analysis. One of the features of the Analysis ToolPak is the Descriptive Statistics tool, which allows users to quickly calculate basic statistical measures for a data set. If you are using the Office 365 version, in your MS Excel file, go to Developer Tab (If Developer Tab not available, then right click on the top ribbon and click on customize ribbon and then check the Developer box) and click on Excel Add Ins and select the "Analysis ToolPak". 

To use the Descriptive Statistics tool in the Analysis ToolPak, follow these steps:

Click on the "Data" tab in the Excel ribbon.

Click on "Data Analysis" in the "Analysis" section.

If the "Data Analysis" option is not visible, you may need to install the Analysis ToolPak add-in first.

Select "Descriptive Statistics" from the list of tools, then click "OK."

In the "Descriptive Statistics" dialog box, select the range of data you want to analyze.

Choose the output options you want to include, such as the mean, standard deviation, and quartiles.

Click "OK" to generate the results.

The output of the Descriptive Statistics tool will include a summary table with basic statistical measures for the selected data set, such as the mean, standard deviation, minimum and maximum values, and quartiles. It can also include a histogram or frequency distribution chart to help visualize the distribution of the data.

The Descriptive Statistics tool is useful for quickly analyzing the basic characteristics of a data set. It can be used in a variety of applications, such as market research, scientific analysis, and financial forecasting.

In summary, the Descriptive Statistics tool in the Analysis ToolPak add-in for Microsoft Excel provides a quick and easy way to calculate basic statistical measures for a data set. It is a useful tool for data analysis and can be used in a variety of applications.

SQL Query in Excel using Power Query

 --For running SQL Query using Power Query, Go to Data Tab, Get Data, From Other Sources, Blank Query, then in query window click on Advanced Editor and use below syntax as per need.

let

    Source = Sql.Database("ServerName",  "DatabaseName", [Query=" Select ID, personname from abc..person where ID= 306258"])

in

    Source

And if we want to use Query syntax from Excel file where it is available as  a named range then use below syntax. Please note the QueryValue in below syntax is a named range cell where query is available

let

    Source = Sql.Database("ServerName",  "DatabaseName", [Query= Excel.CurrentWorkbook(){[Name="QueryValue"]}[Content]{0}[Column1]])

in

    Source

Spell Check VBA Code/Macro

 We can use below code to run against long list of rows having text, to highlight misspelled words in red. Just select the rows and run this code.

Sub Spell()

Dim cel As Range, CellLen As Long, CurChr As Long, TheString As String

For Each cel In Selection

    For CurChr = 1 To Len(cel.Value)

        If Asc(Mid(cel.Value, CurChr, 1)) = 32 Then

            If InStr(CurChr + 1, cel.Value, " ") = 0 Then

                TheString = Mid(cel.Value, CurChr + 1, Len(cel.Value) - CurChr)

            Else

                TheString = Mid(cel.Value, CurChr + 1, InStr(CurChr + 1, cel.Value, " ") - CurChr)

            End If

            If Not Application.CheckSpelling(Word:=TheString) Then

                cel.Characters(CurChr + 1, Len(TheString)).Font.Color = RGB(255, 0, 0)

            Else

                cel.Characters(CurChr + 1, Len(TheString)).Font.Color = RGB(0, 0, 0)

            End If

            TheString = ""

        End If

    Next CurChr

Next cel

End Sub

Excel: Bus/Transport Seat Booking/Ticketing System/Management in Excel U...

Payroll/Salary System in Excel, Complete/Automated with File; Urdu/Hindi

Advance Formatting Techniques in Excel; Urdu/Hindi

Learn Excel with Solved Test Urdu/Hindi

Count Words Frequency in Excel using VBA; Code available Urdu/Hindi

Below is the Code

Sub Separator2()

Sheets("sheet1").Columns("B").ClearContents

Sheets("sheet1").Columns("C").ClearContents

Dim TextStrng As String

Dim Result() As String

TextStrng = Cells(1, 1).Value

TextStrng = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(TextStrng, ",", ""), ".", ""), ":", ""), "the ", " "), "and ", " "), " to ", " "), " of ", " "), " a ", " "), "that ", " "), " in ", " "), "said ", " "), " he ", " "), " she ", " "), " on ", " "), " for ", " "), " had ", " "), " was ", " "), " not ", " "), vbLf, "")

Result = Split(TextStrng, " ")

For i = LBound(Result()) To UBound(Result())

b = i + 1

Cells(b, 2).Value = Result(i)

Next i

Sheets("Sheet1").Columns("B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("sheet1").Columns("C"), Unique:=True

    

    For iCounter = 1 To WorksheetFunction.CountA(Columns(3))

    Range("D" & iCounter).Value = WorksheetFunction.CountIf(Range("B:B"), Cells(iCounter, 3).Value)

Next iCounter

Worksheets("Sheet1").Sort.SortFields.Clear

Range("C:D").Sort Key1:=Range("D1"), Header:=xlNo, Order1:=xlDescending

num2 = WorksheetFunction.CountA(Columns(4))

Range("C" & 21 & ":" & "D" & num2).ClearContents

End Sub

Journal, Ledger, Trial Balance in Excel; Fully Automated Urdu/Hindi

Excel formula range changed/reference error after query refresh: Indirect Function

Suppose we have added a sql query (using ODBC connection) and from the results, we are referring cells or range in excel formula, so when the results are refreshed, the range gets changed or we simply loose reference and get refer error.

Solution:

Instead of referring a cell directly like =A1, we can use Indirect function. Like =Indirect("A1"). Please note the quotes around cell reference, the INDIRECT function is making it a string output which is then interpreted as a cell reference and that trick helps in not loosing cell or range reference after query results refresh.

If we want to refer a cell in a different sheet, then we can do that as well with INDIRECT function, in below example we are referring Sheet2's F1 cell.

=INDIRECT("Sheet2!"&"f1")

Refer a Sheet with space(s) in Name using INDIRECT Function

And if the sheet name have spaces in it, use the single quotes along, like below.

=INDIRECT("'Summary Sheet'"&"!"&"A1")

Matching and Displaying a RegEx Pattern in a String and storing in Excel Rows

Suppose in Column A we have certain text and we want to search a pattern/certain words in the row and store the searched/found words, separated by comma in very next column B's respective row.

For that we can use the below Excel VBA code. Put the text data in Column A and select them and then run the below code, the results would be stored in column B. And Column C will have the label as per the words in Column 2. Change the Regex pattern as per your need.

Please note In order to use Regex in VBA, you first have to set the reference in the VBE editor. In the VBE editor, go to Tools>References>Microsoft VBScript Regular Expressions.

Below is the VBA code for use.

Sub amiq()

Dim strPattern As String: strPattern = "oil|gas|coal|sport|physical|gym|fitness"

Dim regEx As New RegExp

Dim strInput As String

Dim r As Integer

For r = 2 To Selection.Rows.Count

If strPattern <> "" Then

strInput = Cells(r, 1).Value

Values = ""

With regEx

.Global = True

'.MultiLine = True

.IgnoreCase = True

.Pattern = strPattern

End With

Set theMatches = regEx.Execute(strInput)

For Each Match In theMatches

Values = Values & ", " & Match.Value

If Values <> "" Then

Cells(r, 2).Value = Values

Else

Cells(r, 2).Value = "Not FOUND"

End If

If InStr(1, Cells(r, 2).Value, "oil", 1) > 0 or InStr(1, Cells(r, 2).Value, "coal", 1) > 0 or InStr(1, Cells(r, 2).Value, "gas", 1) > 0 then

Cells(r, 3).Value = "Energy

elseif InStr(1, Cells(r, 2).Value, "sport", 1) > 0 or InStr(1, Cells(r, 2).Value, "physical", 1) > 0 then

Cells(r, 3).Value = "Sports"

elseif InStr(1, Cells(r, 2).Value, "Gym", 1) > 0 or InStr(1, Cells(r, 2).Value, "fitness", 1) > 0 then

Cells(r, 3).Value = "Gym"

end if

Next

End If

Next r

End Sub

Gantt Chart in MS Excel; Urdu/Hindi, just two minutes

MS Excel Pivot & Power Pivot Table in Urdu/Hindi; Complete in 7 minutes