常用代码归集

jsgj2023

Sub word基础操作汇集()
Dim wdapp As Word.Application
Dim wdoc As Document
Set wdapp = New Word.Application
dd = ThisWorkbook.Path & "\Adele\销售明细表.dotm"
Set wdoc = wdapp.Documents.Add(dd) '新建
wdapp.Visible = True
wdoc.Tables(1).Range.Cells(2).Range = "商品名称" '向单元格中写入数据
wdapp.Documents(1).SaveAs Filename:="c:\Adele.docx" '保存到C盘
wdapp.Documents.Close
wdapp.Documents.Open (ThisWorkbook.Path & "\Adele\销售明细表.docx") '打开
wdapp.Quit
Set wdapp = Nothing
Set wdoc = Nothing
End Sub

jsgj2023

Sub 将指定单元格的数值数据转化为对应的大写()
    Dim r1, r2, r3, r4, r5 As Range
    Dim r, c As Integer
    Set r1 = ThisWorkbook.Sheets(1).UsedRange
    Set r2 = r1.Range("G4")
    r = r2.End(xlDown).Row
    For c = 3 To r
        Set r3 = r1.Range("G" & c)
        Set r4 = r1.Range("H" & c)
        r4.Value = r3.Value
        r4.NumberFormat = "[dbnum2]"
    Next c
    Set r5 = Columns("H")
    r5.EntireColumn.AutoFit
End Sub

jsgj2023

Sub 删除表格中的重复记录并重填序号()
    Dim r1, r2, r3 As Range, o, n%, c%
    Set r1 = ThisWorkbook.Sheets(1).UsedRange
    Set r2 = r1.Range("B4")
    o = r2.End(xlDown).Row
    r1.RemoveDuplicates Columns:=Array(2, 3, 4, 5, 6, 7, 8, 9), Header:=xlYes
    n = r2.End(xlDown).Row
    c = o - n
    Set r3 = ThisWorkbook.Sheets(1).Range("A3:A" & n)
    With r3.Cells(1)
       .Value = 1
       .AutoFill Destination:=r3, Type:=xlFillSeries
    End With
End Sub

jsgj2023

Sub 根据指定的打印份数打印指定工作表()
Dim sh As Worksheet
Dim x As Integer
Dim y As Variant
Set sh = ThisWorkbook.Sheets(1)
On Error GoTo tag
x = Range("D19").Value
sh.PageSetup.PrintArea = "A1:X17"
sh.PrintOut copies:=x, collate:=True, IgnorePrintAreas:=False
Set sh = Nothing
Exit Sub
tag:
y = MsgBox("设置的打印份数有误，是否重新设置？  ", vbYesNo)
If y = vbYes Then
    Call PrintOutBtn_Click
Else
    MsgBox "程序终止运行！  ", vbInformation
End If
End Sub

jsgj2023

Sub 在excel中打开txt文件()
Dim myfilename  As String
myfilename = "students.txt"
Workbooks.OpenText _
    Filename:=ThisWorkbook.Path & "\" & myfilename, _
    startrow:=1, DataType:=xlDelimited, comma:=True
End Sub

jsgj2023

Sub excel中打开csv文件()
Dim myfilename As String
myfilename = "Adele.csv"
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & myfilename
End Sub

jsgj2023

Sub 读取txt文本()
Dim mycnc1 As String
Dim mycnc2 As String
Dim myfilename As String
myfilename = "students.txt"
mycnc1 = "TEXT;"
mycnc2 = ThisWorkbook.Path & "\" & myfilename
With ActiveSheet.QueryTables.Add( _
    Connection:=mycnc1 & mycnc2, _
    Destination:=Range("a1"))
    .TextFilePlatform = 936
    TextFileCommaDelimiter = True
    .Refresh
End With
End Sub

jsgj2023

Sub 读取csv格式文件数据()
    Dim myCnc1 As String
    Dim myCnc2  As String
    Dim myFileName As String
    myFileName = "Adele.csv"
    myCnc1 = "TEXT;"
    myCnc2 = ThisWorkbook.Path & "\" & myFileName
    ActiveSheet.Cells.Clear
    With ActiveSheet.QueryTables.Add( _
        Connection:=myCnc1 & myCnc2, _
        Destination:=Range("A1"))
        .TextFilePlatform = 936
        .TextFileCommaDelimiter = True
        .Refresh
    End With
End Sub

jsgj2023

Sub 读取指定文本文件指定行的文本内容()
Dim fso As Scripting.FileSystemObject
Dim mytxt As Scripting.TextStream
Dim myfile As String
Dim i As Long
ActiveSheet.Cells.Clear
myfile = ThisWorkbook.Path & "\Adele.txt"
Set fso = New Scripting.FileSystemObject
Set mytxt = fso.OpenTextFile(Filename:=myfile, IOMode:=ForReading)
With mytxt
    For i = 1 To 8
        .SkipLine
    Next i
    MsgBox "文本文件的第9行数据为:" & .ReadLine
    .Close
End With
Set mytxt = Nothing
Set fso = Nothing
End Sub

jsgj2023

Sub sql读取csv文件数据()
    Dim cnn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim myCnnstr As String
    Dim sql As String
    Dim myfilename As String
    Dim i   As Long
    ActiveSheet.Cells.Clear
    myfilename = "Adele.csv"
    myCnnstr = "driver={microsoft text driver (*.txt; *.csv)};" & _
        "DBQ=" & ThisWorkbook.Path & "\;"
        cnn.Open "provider=msdasql;" & myCnnstr
        sql = "select * from " & myfilename
        rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
        For i = 1 To rs.Fields.Count
            Cells(1, i).Value = rs.Fields(i - 1).Name
        Next
        Range("a2").CopyFromRecordset rs
        rs.Close
        cnn.Close
        Set rs = Nothing
        Set cnn = Nothing
End Sub