Sub CopyHTMLFromWordToExcel_WithFilePicker()
    Dim wordApp As Object
    Dim wordDoc As Object
    Dim wordFilePath As String
    Dim tempFilePath As String
    Dim htmlFormattedText As String
    Dim paragraph As Object
    Dim run As Object
    Dim targetCell As Range
    Dim currentLevel As Integer
    Dim previousLevel As Integer
    Dim listStack As Collection
    Dim runText As String
    Dim numberingText As String
    Dim listTag As String
    Dim fileSystemObject As Object
    Dim fileDialog As fileDialog

    ' Ask the user to select the Word file
    Set fileDialog = Application.fileDialog(msoFileDialogFilePicker)
    With fileDialog
        .Title = "Select a Word file to copy"
        .Filters.Clear
        .Filters.Add "Word Documents", "*.doc; *.docx"
        .AllowMultiSelect = False
        If .Show <> -1 Then
            MsgBox "No file was selected. Exiting.", vbExclamation
            Exit Sub
        End If
        wordFilePath = .SelectedItems(1)
    End With

    ' Create a temporary file path
    tempFilePath = Replace(wordFilePath, ".docx", "_temp.docx")

    ' Copy the file to the temporary path
    On Error Resume Next
    Set fileSystemObject = CreateObject("Scripting.FileSystemObject")
    fileSystemObject.CopyFile wordFilePath, tempFilePath, True
    If Err.Number <> 0 Then
        MsgBox "Failed to create a temporary copy of the file.", vbCritical
        Exit Sub
    End If
    On Error GoTo 0

    ' Set the target cell in Excel
    Set targetCell = ThisWorkbook.Sheets("Sheet1").Range("R4") ' Adjust sheet name and cell as needed

    ' Create a Word application instance
    Set wordApp = CreateObject("Word.Application")
    If wordApp Is Nothing Then
        MsgBox "Unable to start Word application. Please ensure Word is installed on your system.", vbExclamation
        Exit Sub
    End If

    ' Run Word in invisible mode
    wordApp.Visible = False

    ' Open the temporary Word document in Read-Only mode
    On Error Resume Next
    Set wordDoc = wordApp.Documents.Open(tempFilePath, ReadOnly:=True)
    If wordDoc Is Nothing Then
        MsgBox "Could not open the temporary Word document.", vbExclamation
        wordApp.Quit
        Set wordApp = Nothing
        Exit Sub
    End If
    On Error GoTo 0

    ' Initialize variables
    htmlFormattedText = ""
    Set listStack = New Collection
    previousLevel = 0

    ' Process the document
    For Each paragraph In wordDoc.Paragraphs
        ' Check if the paragraph has a valid ListFormat
        If paragraph.Range.ListFormat.listType <> 0 Then
            currentLevel = paragraph.Range.ListFormat.ListLevelNumber

            ' Determine the list tag based on the level
            Select Case currentLevel
                Case 1: listTag = "ol" ' Level 1: Numbers (Ordered List)
                Case 2: listTag = "ul" ' Level 2: Bullets (Unordered List)
                Case 3: listTag = "ul" ' Level 3: Squares
            End Select

            ' Adjust list structure based on level
            If currentLevel > previousLevel Then
                Do While currentLevel > previousLevel
                    If currentLevel = 3 Then
                        htmlFormattedText = htmlFormattedText & "<ul style='list-style-type:square;'>" & vbCrLf
                    Else
                        htmlFormattedText = htmlFormattedText & "<" & listTag & ">" & vbCrLf
                    End If
                    listStack.Add listTag
                    previousLevel = previousLevel + 1
                Loop
            ElseIf currentLevel < previousLevel Then
                Do While currentLevel < previousLevel And listStack.Count > 0
                    htmlFormattedText = htmlFormattedText & "</" & Replace(listStack(listStack.Count), " style='list-style-type:square;'", "") & ">" & vbCrLf
                    listStack.Remove listStack.Count
                    previousLevel = previousLevel - 1
                Loop
            End If

            ' Add the list item with numbering for ordered lists
            numberingText = ""
            If paragraph.Range.ListFormat.listType = 3 And currentLevel = 1 Then
                numberingText = paragraph.Range.ListFormat.ListString & " "
            End If

            htmlFormattedText = htmlFormattedText & "<li>" & numberingText
            For Each run In paragraph.Range.Words
                runText = run.Text
                If run.Bold Then runText = "<strong>" & runText & "</strong>"
                If run.Italic Then runText = "<em>" & runText & "</em>"
                If run.Underline <> 0 Then runText = "<u>" & runText & "</u>"
                htmlFormattedText = htmlFormattedText & runText
            Next run
            htmlFormattedText = htmlFormattedText & "</li>" & vbCrLf
        Else
            Do While previousLevel > 0 And listStack.Count > 0
                htmlFormattedText = htmlFormattedText & "</" & Replace(listStack(listStack.Count), " style='list-style-type:square;'", "") & ">" & vbCrLf
                listStack.Remove listStack.Count
                previousLevel = previousLevel - 1
            Loop

            ' Add plain paragraph text
            For Each run In paragraph.Range.Words
                runText = run.Text
                If run.Bold Then runText = "<strong>" & runText & "</strong>"
                If run.Italic Then runText = "<em>" & runText & "</em>"
                If run.Underline <> 0 Then runText = "<u>" & runText & "</u>"
                htmlFormattedText = htmlFormattedText & runText
            Next run
            htmlFormattedText = htmlFormattedText & "<br>" & vbCrLf
        End If
    Next paragraph

    ' Close the Word document
    wordDoc.Close SaveChanges:=False
    wordApp.Quit

    ' Delete the temporary file
    On Error Resume Next
    fileSystemObject.DeleteFile tempFilePath
    On Error GoTo 0

    ' Release objects
    Set wordDoc = Nothing
    Set wordApp = Nothing
    Set fileSystemObject = Nothing

    ' Insert the HTML-formatted text into the specified cell
    targetCell.Value = htmlFormattedText

    ' Notify the user
    MsgBox "HTML-formatted text from the Word document has been copied to cell " & targetCell.Address, vbInformation
End Sub