常用代码归集

jsgj2023

     实践中,经常调用一些代码,代码的来源比较广泛,但绝大部分为解决本论坛朋友提问时编写,还包含所写插件中的部分代码,为便于统一查找引用,我将其逐一归集,希望能给予大家帮助,归集的代码若有涉嫌侵权的嫌疑,请联系我处理!自【393】楼起,每段代码有相应的链接,需要附件的朋友可以自行下载!

jsgj2023

Sub 透视表式汇总()
        Dim d As Object, arr, x&, y%, s, t, a, b, m%, n%, r%
        Dim sh  As Worksheet
        Application.ScreenUpdating = False
        Set d = CreateObject("scripting.dictionary")
        Application.DisplayAlerts = False
        For Each sh In Worksheets
             If Not sh.Name Like "合并结果" Then
                     sh.Delete
             End If
        Next sh
        Application.DisplayAlerts = True
        Sheets.Add(after:=Sheets(Sheets.Count)).Name = "透视表式汇总"
        Sheets("合并结果").Activate
        arr = Range("a1").CurrentRegion
        For x = 2 To UBound(arr)
                If Not d.exists(arr(x, 4)) Then
                        Set d(arr(x, 4)) = CreateObject("scripting.dictionary")
                End If
                d(arr(x, 4))(arr(x, 12)) = d(arr(x, 4))(arr(x, 12)) + arr(x, 9)
        Next x
                s = d.keys: t = d.items
        Sheets("透视表式汇总").Activate
        For m = 0 To d.Count - 1
                a = d(s(m)).keys: b = d(s(m)).items
                n = n + r
                With Sheets("透视表式汇总")
                        .Cells(1, 1).Resize(1, 3) = Array("门店", "型号", "数量")
                        .Cells(2 + n, 1).Resize(d(s(m)).Count, 1) = s(m)
                        .Cells(2 + n, 2).Resize(d(s(m)).Count, 1) = Application.Transpose(a)
                        .Cells(2 + n, 3).Resize(d(s(m)).Count, 1) = Application.Transpose(b)
                        n = 0
                End With
                r = Cells(Rows.Count, 1).End(xlUp).Row - 1
        Next m
        Range("a:c").EntireColumn.AutoFit
        Application.ScreenUpdating = True
End Sub

jsgj2023

Sub 创建文本文件()
Dim astr(1 To 3) As String, i As Integer
Dim sfname As String, ifnumber As Integer, r As Long
sfname = Application.InputBox(prompt:="请输入文本文件的名称", _
Title:="输入文件名称", Type:=2)
If sfname = "False" Or sfname = "" Then Exit Sub
sfname = ThisWorkbook.Path & "\" & sfname & ".txt"
ifnumber = FreeFile
Open sfname For Output As #ifnumber
r = 2
Do
    With Sheet1
        For i = 1 To 3
            astr(i) = .Cells(r, i)
        Next
    End With
    Write #ifnumber, astr(1), astr(2), astr(3)
    r = r + 1
Loop Until IsEmpty(Sheet1.Cells(r, 1))
Close #ifnumber
End Sub

light1275

楼主可以放上事例文件吗？光看代码不好应用

jsgj2023

Sub 读取文本文件数据()
    Dim astr(1 To 3) As String
    Dim i  As Integer
    Dim sfname As String
    Dim ifnumber As Integer
    Dim r As Long
    sfname = Application.InputBox(prompt:="请输入文本文件的名称", _
    Title:="输入文件名称", Type:=2)
    If sfname = "False" Or sfname = "" Then Exit Sub
    sfname = ThisWorkbook.Path & "\" & sfname & ".txt"
    If Len(Dir(sfname, vbDirectory)) > 0 Then
        ifnumber = FreeFile
        Open sfname For Input As #ifnumber
        Sheet1.Cells.Clear
        r = 2
        Do
            Input #ifnumber, astr(1), astr(2), astr(3)
            With Sheet1
                For i = 1 To 3
                    .Cells(r, i) = astr(i)
                Next
            End With
            r = r + 1
        Loop Until EOF(ifnumber)
        Close #ifnumber
    Else
        MsgBox "输入的文件不存在,请不要添加扩展名!"
    End If
End Sub

jsgj2023

Sub 保存文本文件()
Dim sfname As String
sfname = Application.InputBox(prompt:="请输入文本文件的名称", _
Title:="输入文件名称", Type:=2)
If afname = "False" Or sfname = "" Then Exit Sub
sfname = ThisWorkbook.Path & "\" & sfname & ".txt"
On Error Resume Next
If Len(Dir(sfname, vbDirectory)) > 0 Then
    If MsgBox("该文件已经存在,是否删除?", vbQuestion + vbYesNo) = vbYes Then
        Kill sfname
    Else
        Exit Sub
    End If
End If
On Error GoTo 0
Set ws1 = Worksheets("Sheet1")
ActiveWorkbook.SaveAs Filename:=sfname, FileFormat:=xlCSV
MsgBox "保存成功!"
ActiveWorkbook.Close savechanges:=False
End Sub

jsgj2023

Sub 创建文本文件()
    Dim fso   As New Scripting.FileSystemObject
    Dim ostream As Scripting.TextStream
    Dim sfname As String
    Dim str1 As String
    sfname = Application.InputBox(prompt:="请输入文本文件的名称", _
    Title:="输入文件名称", Type:=2)
    If sfname = "False" Or sfname = "" Then Exit Sub
    sfname = ThisWorkbook.Path & "\" & sfname & ".txt"
    Set ostream = fso.CreateTextFile(Filename:=sfname, overwrite:=True)
    r = 2
    Do
        With Sheet1
            str1 = ""
            For i = 1 To 3
                str1 = str1 & .Cells(r, i) & ","
            Next
        End With
        ostream.WriteLine Left(str1, Len(str1) - 1)
    Loop Until IsEmpty(Sheet1.Cells(r, 1))
    ostream.Close
    MsgBox "文本文件创建成功!"
    Set ostream = Nothing
    Set fso = Nothing
End Sub

未忘初心

感谢分享❀

jsgj2023

Sub 添加数据到文本文件()
Dim fso As New Scripting.FileSystemObject
Dim ostream As Scripting.TextStream
Dim sfname As String
sfname = Application.InputBox(prompt:="请输入文本文件的名称", _
Title:="请输入文件名称", Type:=2)
If sfname = "False" Or sfname = "" Then Exit Sub
sfname = ThisWorkbook.Path & "\" & sfname & ".txt"
If Not fso.FileExists(sfname) Then
    MsgBox "该文件不存在!", vbInformation + vbOKOnly
    Exit Sub
End If
Set ostream = fso.OpenTextFile(Filename:=sfname, IOMode:=ForAppending)
With ostream
    .WriteLine "追加第1行数据!"
    .WriteLine "追加第2行数据!"
    .WriteLine "追加第3行数据!"
End With
ostream.Close
MsgBox "文本文件追加数据成功!"
Set ostream = Nothing
Set fso = Nothing
End Sub

jsgj2023

Sub 读取文本文件数据()
Dim fso As New Scripting.FileSystemObject
Dim ostream As Scripting.TextStream
Dim sfname As String
Dim str1 As String
sfname = Application.InputBox(prompt:="请输入文本文件的名称", _
Title:="输入文件名称", Type:=2)
If sfname = "False" Or sfname = "" Then Exit Sub
sfname = ThisWorkbook.Path & "\" & sfname & ".txt"
If Not fso.FileExists(sfname) Then
    MsgBox "该文件不存在!", vbInformation + vbOKOnly
    Exit Sub
End If
Set osteam = fso.OpenTextFile(Filename:=sfname, IOMode:=ForReading)
str1 = osteam.ReadAll
osteam.Close
MsgBox str1
Set ostream = Nothing
Set fso = Nothing
End Sub