常用代码归集

jsgj2023

Sub sql提取指定条件的数据()
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 _
    & " where 数学>=90 and 语文>=90"
    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

jsgj2023

Sub 苏宁系统数量和金额匹配_以原始数据为基础()
If MsgBox("请选择苏宁系统各门店当期销售金额汇总工作簿," _
& "确保该簿中有《合并结果》表！", vbYesNo + vbQuestion + vbDefaultButton1) = vbYes Then
    GoTo 100
Else
    Exit Sub
End If
100:
strfind = Application.InputBox("请输入开始日期：", Type:=1)
Dim d As Object, sh As Worksheet
Dim arr, brr, crr(), wb As Workbook
Dim x&, y&, z&, k&
Dim i&, j&, n&
Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary")
Set dnow = CreateObject("scripting.dictionary")
With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = False
    If .Show Then p = .SelectedItems(1) Else: Exit Sub
End With
With GetObject(p)
    arr = .Sheets("合并结果").Range("a1").CurrentRegion
    .Close False
    For x = 2 To UBound(arr)
        If arr(x, 13) > strfind Then
            sell = arr(x, 10) & "+" & arr(x, 13) & "+" & arr(x, 16)
            d(sell) = d(sell) + arr(x, 18)
        End If
    Next
End With
Set wb = ActiveWorkbook
With wb
    brr = .Sheets("合并结果").Range("a1").CurrentRegion
    Application.DisplayAlerts = False
    For Each sh In .Sheets
        If sh.Name = "提取结果" Then sh.Delete
    Next
    Application.DisplayAlerts = True
    For y = 2 To UBound(brr)
        nowsell = brr(y, 3) & "+" & brr(y, 1) & "+" & brr(y, 7)
        dnow(nowsell) = dnow(nowsell) + brr(y, 9)
    Next y
    anow = dnow.keys
    bnow = dnow.items
    ReDim crr(1 To UBound(anow) + 1, 1 To 3)
    For z = 0 To UBound(anow)
        k = k + 1
        crr(k, 1) = anow(z)
        crr(k, 2) = bnow(z)
    Next z
    For i = 1 To UBound(crr)
        If d.exists(crr(i, 1)) Then
            crr(i, 3) = d(crr(i, 1))
        End If
    Next i
    ReDim Preserve crr(1 To UBound(crr), 1 To UBound(crr) + 3)
    For j = 1 To UBound(crr)
        n = n + 1
        spl = Split(crr(j, 1), "+")
        crr(j, 4) = spl(0)
        crr(j, 5) = spl(1)
        crr(j, 6) = spl(2)
    Next j
    .Sheets.Add(after:=Sheets(Sheets.Count)).Name = "提取结果"
    With .Sheets("提取结果")
        .[a1].Resize(1, 6) = Array("三项集合", "数量", "金额", "门店代码", "销售时间", "商品名称")
        .[a2].Resize(UBound(crr), UBound(crr, 2)) = crr
    End With
End With
Application.ScreenUpdating = True
End Sub

jsgj2023

Sub 统计指定文本文件的行数和列数()
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 n As Long
Dim m As Integer
ActiveSheet.Cells.Clear
myfilename = "Adele.csv"
mycnnstr = "driver={microsoft text driver (*.txt; *.csv)};" & "dbq=" & ThisWorkbook.Path & "\;"
sql = "select * from " & myfilename
cnn.Open "provider=msdasql;" & mycnnstr
rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
n = rs.RecordCount
m = rs.Fields.Count
MsgBox "该文本文件的行数为:" & n & "列数为:" & m, vbInformation
rs.Close: cnn.Close
Set rs = Nothing: Set cnn = Nothing
End Sub

jsgj2023

Sub 指定文件读入表格_input()
Dim filename As Variant
Dim mytext As Variant
Dim marr()   As String
Dim i As Long
Dim j As Long
filename = ThisWorkbook.Path & "\Adele.csv"
j = 1
With Sheets("sheet1")
    .Cells.ClearContents
    Open filename For Input As #1
    Do While Not EOF(1)
        Line Input #1, mytext
        marr = Split(mytext, ",")
        For i = 0 To UBound(marr)
            .Cells(j, i + 1) = marr(i)
        Next i
        j = j + 1
    Loop
    Close #1
End With
End Sub

jsgj2023

Sub 保存文件为指定的文件名并删除已有的同名文件()
Dim myfilename As String
myfilename = "Adele.csv"
On Error Resume Next
Kill ThisWorkbook.Path & "\" & myfilename
On Error GoTo 0
Worksheets("Sheet1").Copy
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & myfilename, FileFormat:=xlCSV
MsgBox "保存成功!"
ActiveWorkbook.Close savechanges:=False
End Sub

jsgj2023

Sub xls格式转换为csv格式()
    Dim myfilename As String
    Dim mydataar() As Variant
    Dim mystr As String
    Dim i  As Long
    Dim finalrow As Long
    Dim j   As Long
    Dim finalcol As Long
    myfilename = "Adele.csv"
    On Error Resume Next
    Kill ThisWorkbook.Path & "\" & myfilename
    On Error GoTo 0
    finalrow = Range("a65536").End(3).Row
    finalcol = Range("iv1").End(xlToLeft).Column
    ReDim mydataar(1 To finalrow, 1 To finalcol)
    For i = 1 To finalrow
        For j = 1 To finalcol
            mydataar(i, j) = Cells(i, j).Value
        Next
    Next
    Open ThisWorkbook.Path & "\" & myfilename For Output As #1
    For i = 1 To UBound(mydataar, 1)
        mystr = ""
        For j = 1 To UBound(mydataar, 2)
            mystr = mystr & CStr(mydataar(i, j)) & ","
        Next
        mystr = Left(mystr, (Len(mystr) - 1))
        Print #1, mystr
    Next
    Close #1
    MsgBox "保存成功!"
End Sub

jsgj2023

Sub 苏宁系统数量和金额匹配_以原始数据为基础()
If MsgBox("请选择苏宁系统各门店当期销售金额汇总工作簿," _
& "确保该簿中有《合并结果》表！", vbYesNo + vbQuestion + vbDefaultButton1) = vbYes Then
    GoTo 100
Else
    Exit Sub
End If
100:
strfind = Application.InputBox("请输入当期销售报表的起始日期：", Type:=1)
Dim d As Object, sh As Worksheet
Dim arr, brr, crr(), wb As Workbook
Dim x&, y&, z&, k&
Dim i&, j&
Dim dStandard As Object
Dim arrStandard, xstd&, kFinal As Variant, sFinal As String
Dim dFinal  As Object, xFinal&
Dim arrFinal As Variant, n&, kk&, splFinal As Variant
Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary")
Set dnow = CreateObject("scripting.dictionary")
With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = False
    If .Show Then p = .SelectedItems(1) Else: Exit Sub
End With
With GetObject(p)
    arr = .Sheets("合并结果").Range("a1").CurrentRegion
    .Close False
    For x = 2 To UBound(arr)
        If arr(x, 13) > strfind Then
            If arr(x, 10) = "9019" Or arr(x, 10) = "8417" Then
                sell = arr(x, 10) & "+" & arr(x, 13) & "+" & arr(x, 16) '门店代码+销售时间+商品名称
                d(sell) = d(sell) + arr(x, 18)
            End If
        End If
    Next
End With
'sj门店代码  9019
'sm门店代码  8417
Set wb = ActiveWorkbook
With wb
    brr = .Sheets("合并结果").Range("a1").CurrentRegion
    Application.DisplayAlerts = False
    For Each sh In .Sheets
        If sh.Name = "提取结果" Then sh.Delete
    Next
    Application.DisplayAlerts = True
    For y = 2 To UBound(brr)
        If brr(y, 3) = "9019" Or brr(y, 3) = "8417" Then
            nowsell = brr(y, 3) & "+" & brr(y, 1) & "+" & brr(y, 7) '门店代码+销售时间+商品名称
            dnow(nowsell) = dnow(nowsell) + brr(y, 9)
        End If
    Next y
    anow = dnow.keys
    bnow = dnow.items
    ReDim crr(1 To UBound(anow) + 1, 1 To 3)
    For z = 0 To UBound(anow)
        k = k + 1
        crr(k, 1) = anow(z)
        crr(k, 2) = bnow(z)
    Next z
    For i = 1 To UBound(crr)
        If d.exists(crr(i, 1)) Then
            crr(i, 3) = d(crr(i, 1))
        End If
    Next i
    ReDim Preserve crr(1 To UBound(crr), 1 To UBound(crr) + 4)
    '==============型号标准数据=================
    Set dStandard = CreateObject("scripting.dictionary")
    With GetObject("C:\Users\Administrator\AppData\Roaming\Microsoft\AddIns" & "\单品名称和型号标准数据表.xlsx")
        arrStandard = .Sheets("苏宁系统结算平台型号整理-字典法").[a1].CurrentRegion
        .Close False
    End With
    For xstd = 2 To UBound(arrStandard)
        If Not dStandard.exists(arrStandard(xstd, 1)) Then
            dStandard(arrStandard(xstd, 1)) = arrStandard(xstd, 2)
        End If
    Next
    '==============型号标准数据=================
    For j = 1 To UBound(crr)
        spl = Split(crr(j, 1), "+")
        crr(j, 4) = spl(0)
        crr(j, 5) = spl(1)
        crr(j, 6) = spl(2)
        If dStandard.exists(crr(j, 6)) Then
            crr(j, 7) = dStandard(crr(j, 6))
        End If
    Next j
  '============对提取的金额和数量分类汇总=====================
      Set dFinal = CreateObject("scripting.dictionary")
      For xFinal = 1 To UBound(crr)
        sFinal = crr(xFinal, 4) & "+" & crr(xFinal, 7)
        If Not dFinal.exists(sFinal) Then
            dFinal(sFinal) = Array(crr(xFinal, 2), crr(xFinal, 3))
        Else
            kFinal = dFinal(sFinal)
            kFinal(0) = kFinal(0) + crr(xFinal, 2)
            kFinal(1) = kFinal(1) + crr(xFinal, 3)
            dFinal(sFinal) = kFinal
        End If
      Next
      afinal = dFinal.keys
      bfinal = dFinal.items
      ReDim arrFinal(1 To UBound(afinal) + 1, 1 To 4)
      For n = 0 To UBound(afinal)
        kk = kk + 1
        splFinal = Split(afinal(n), "+")
        arrFinal(kk, 1) = splFinal(0)
        arrFinal(kk, 2) = splFinal(1)
        arrFinal(kk, 3) = bfinal(n)(0)
        arrFinal(kk, 4) = bfinal(n)(1)
      Next
      '============对提取的金额和数量分类汇总=====================
    .Sheets.Add(after:=Sheets(Sheets.Count)).Name = "提取结果"
    With .Sheets("提取结果")
        .[a1].Resize(1, 4) = Array("门店代码", "商品名称", "数量", "金额")
        .[a2].Resize(UBound(arrFinal), UBound(arrFinal, 2)) = arrFinal
        .Range("a:g").EntireColumn.AutoFit
    End With
End With
Application.ScreenUpdating = True
End Sub

jsgj2023

Sub 往指定的文本文件中写入数据()
Dim fso As Scripting.FileSystemObject
Dim mytxt As Scripting.TextStream
Dim myfile As String
myfile = ThisWorkbook.Path & "\FSOTest.txt"
Set fso = New Scripting.FileSystemObject
Set mytxt = fso.CreateTextFile(Filename:=myfile, overwrite:=True)
With mytxt
    .Write "我爱Adele"
    .Write "第一行" & vbCrLf
    .WriteBlankLines 5
    .WriteLine "第七行"
    .WriteLine "第八行"
    .Write "第9行" & vbCrLf & "第10行"
    .Close
End With
Set mytxt = Nothing
Set fso = Nothing
End Sub

jsgj2023

Sub 在指定文本文件的末尾插入新的数据()
Dim fso As Scripting.FileSystemObject
Dim f As Scripting.File
Dim mytxt  As Scripting.TextStream
Dim myfile As String
myfile = ThisWorkbook.Path & "\Adele.txt"
Set fso = New Scripting.FileSystemObject
Set f = fso.GetFile(myfile)
Set mytxt = f.OpenAsTextStream(ForAppending)
With mytxt
    .WriteLine "插入Adele的心中"
    .Close
End With
Set mytxt = Nothing
Set fso = Nothing

jsgj2023

Sub 将指定文本文件的数据导入excel()
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
    i = 1
    Do Until .AtEndOfStream
        Cells(i, 1) = .ReadLine
        i = i + 1
    Loop
    .Close
End With
Set mytxt = Nothing
Set fso = Nothing
End Sub