历史评论归档

运行后很多问号。

Sub GetWordTable()

    '??word???????excel

    Dim WdApp As Object

    Dim objTable As Object

    Dim objDoc As Object

    Dim strPath As String

    Dim shtEach As Worksheet

    Dim shtSelect As Worksheet

    Dim k As Long, x As Long, y As Long

    Dim i As Long, j As Long

    Dim brr As Variant

    On Error Resume Next

    Set WdApp = CreateObject("Word.Application")

    With Application.FileDialog(msoFileDialogFilePicker)

        .Filters.Add "Word??", "*.doc*", 1

        '???word??

        .AllowMultiSelect = False

        '??????

        If .Show Then strPath = .SelectedItems(1) Else Exit Sub

    End With

    Application.ScreenUpdating = False

    Application.DisplayAlerts = False

    Set shtSelect = ActiveSheet

    '???????shtSelect,????????????????????

    For Each shtEach In Worksheets

    '???????????????

        If shtEach.Name <> shtSelect.Name Then shtEach.Delete

    Next

    shtSelect.Name = "?"

    '????????,????……??……

    '……?????????????????

    Set objDoc = WdApp.Documents.Open(strPath)

    '?????????word??

    For Each objTable In objDoc.Tables

    '??????????

        k = k + 1

        Worksheets.Add After:=Worksheets(Worksheets.Count)

        '?????

        ActiveSheet.Name = k & "?"

         '?????????????????????,????????,???????????

        x = objTable.Rows.Count

        'table???

        y = objTable.Columns.Count

        'table???

        ReDim brr(1 To x, 1 To y)

        '??????,??????brr

        For i = 1 To x

            For j = 1 To y

                brr(i, j) = "'" & Application.Clean(objTable.Cell(i, j).Range.Text)

                'Clean????????

                '?????????????????,??????????

            Next

        Next

        With [A1].Resize(x, y)

            .Value = brr

            '????Excel???

            .Borders.LineStyle = 1

            '?????

        End With

    Next

    shtSelect.Select

    objDoc.Close: WdApp.Quit

    Application.ScreenUpdating = True

    Application.DisplayAlerts = True

    Set objDoc = Nothing

    Set WdApp = Nothing

    MsgBox "???:" & k & "???????"

End SubOption Explicit

Sub RMB()

     Dim Numeric As Currency, IntPart As Long, DecimalPart As Byte, MyField As Field, Lable As String

     Dim Jiao As Byte, Fen As Byte, Oddment As String, Odd As String, MyChinese As String

     Const ZWDX As String = "Ò¼·¡ÈþËÁÎé½Æâ°Æ¾ÁÁã"      '¶¨ÒåÒ»¸öÖÐÎÄ´óдºº×Ö³£Á¿

     On Error Resume Next      '´íÎóºöÂÔ

     With Selection

       Numeric = VBA.Round(VBA.Val(.Text), 2)      'ËÄÉáÎåÈë±£ÁôСÊýµãºóÁ½Î»

       'ÅжÏÊÇ·ñÔÚ±í¸ñÖÐ

       If .Information(wdWithInTable) Then _

.MoveRight unit:=wdCell Else .MoveRight unit:=wdCharacter

       '¶ÔÊý¾Ý½øÐÐÅжÏ,ÊÇ·ñÔÚÖ¸¶¨µÄ·¶Î§ÄÚ

       If VBA.Abs(Numeric) > 2147483647 Then MsgBox "ÊýÖµ³¬¹ý·¶Î§!", _

                                     vbOKOnly + vbExclamation, "Warning": Exit Sub

       IntPart = Int(VBA.Abs(Numeric))      '¶¨ÒåÒ»¸öÕýÕûÊý

       Odd = VBA.IIf(IntPart = 0, "", "Ôª")      '¶¨ÒåÒ»¸öSTRING±äÁ¿

       '²åÈëÖÐÎÄ´óдǰµÄ±êÇ©

       Lable = VBA.IIf(Numeric = VBA.Abs(Numeric), "ÈËÃñ±Ò", "ÈËÃñ±Ò¸º")

       '¶ÔСÊýµãºóÃæ¶þλÊý½øÐÐÔñ¶¨

       DecimalPart = (VBA.Abs(Numeric) - IntPart) * 100

       Select Case DecimalPart

       Case Is = 0      'Èç¹ûÊÇ0,¼´ÊÇÑ¡¶¨µÄÊý¾ÝΪÕûÊý

           Oddment = VBA.IIf(Odd = "", "", Odd & "Õû")

       Case Is < 10      '<10,¼´ÊÇÁãÍ·ÊÇ·Ö

           Oddment = VBA.IIf(Odd <> "", "ÔªÁã" & VBA.Mid(ZWDX, DecimalPart, 1) & "·Ö", _

                       VBA.Mid(ZWDX, DecimalPart, 1) & "·Ö")

       Case 10, 20, 30, 40, 50, 60, 70, 80, 90      'Èç¹ûÊǽÇÕû

           Oddment = "Ôª" & VBA.Mid(ZWDX, DecimalPart / 10, 1) & "½ÇÕû"

       Case Else      '¼ÈÓнÇ,ÓÖÓзֵÄÇé¿ö

           Jiao = VBA.Left(CStr(DecimalPart), 1)      'È¡µÃ½ÇÃæÖµ

           Fen = VBA.Right(CStr(DecimalPart), 1)      'È¡µÃ·ÖÃæÖµ

           Oddment = Odd & VBA.Mid(ZWDX, Jiao, 1) & "½Ç"      'ת»»Îª½ÇµÄÖÐÎÄ´óд

           Oddment = Oddment & VBA.Mid(ZWDX, Fen, 1) & "·Ö"      'ת»»Îª·ÖµÄÖÐÎÄ´óд

       End Select

       'Ö¸¶¨ÇøÓò²åÈëÖÐÎÄ´óд¸ñʽµÄÓò

       Set MyField = .Fields.Add(Range:=.Range, Text:="= " & IntPart & " \*CHINESENUM2")

       MyField.Select      'Ñ¡¶¨Óò(×îºóÊÇÓÃÖ¸¶¨Îı¾¸²¸ÇÑ¡¶¨ÇøÓò)

       'Èç¹û½öÓнǷÖÇé¿öÏÂ,MychineseΪ""

       MyChinese = VBA.IIf(MyField.Result <> "Áã", MyField.Result, "")

       .Text = Lable & MyChinese & Oddment

     End With

End Sub

sorry ，我不会用