[原创]确实好用,非常不错

j21449

发我一个,myjhhf@yahoo.com.cn

谢谢,

yfzyfz

谢谢！请帮我传一份！ yfz1999@126.com

jincui

我想用啊

请发给我把

hbxwjincui@126.com

ysjfnkml

Public Declare Function GetVolumeInformation Lib "kernel32" _
Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, _
ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, _
lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, _
lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, _
ByVal nFileSystemNameSize As Long) As Long
Sub Yjue_1()
MsgBox "请在对帐过程中不要进行其他任何操作，否则对帐数据会发生错误！", vbOKOnly + 100000, "警告"
Sheets("数据输入区").Select
Dim hh, kk, p, p2, a, j%, c, w%, ee, pdzc, y1, y2, y3, y4, y, xxx
y1 = Sheets("数据输入区").Range("B65536").End(xlUp).Row
y2 = Sheets("数据输入区").Range("D65536").End(xlUp).Row
y3 = Sheets("数据输入区").Range("G65536").End(xlUp).Row
y4 = Sheets("数据输入区").Range("I65536").End(xlUp).Row

y = 6
If y1 >= y2 Then 'y为y1和y2中最大的数
y = y1
Else
y = y2
End If

If y < y3 Then '如果y小于y3，则将y3赋给y
   y = y3
End If

If y < y4 Then '如果y小于y4，则将y4赋给y
   y = y4
End If

Range("a8:a65536,c8:c65536,f8:f65536,h8:h65536").Select
 Selection.ClearContents
 Range("a8").Select

Dim xs, bs, ps, ms '时间
If Second(Now) = 59 Then
   xs = -1
Else
   xs = Second(Now)
End If
ms = 0
ps = 0
'时间

Open ("c:\windows\system32\pdzc.dll") For Input As #1
 Input #1, pdzc
 Close

If pdzc = 0 Then
   y = 57
   MsgBox "您未注册，最多只能执行50行对帐数据！", vbOKOnly + 100000, "警告"
End If

frmjdt.Show

frmjdt.Label1.Caption = "正在进行（一四）付出款项对帐，请稍候......"
h = 8 '冲付帐
ee = 0
Do While h <= y
  If Range("b" & h) <> "" Then
     k = 8
     Do While k <= y
        If Range("h" & k) <> "√" And Range("b" & h) = Range("i" & k) Then
       
              Range("a" & h) = "√"
              Range("h" & k) = "√"
              k = y
       
        End If
        k = k + 1
     Loop
  End If
        p = CStr(Int(h / y * 16))
        p2 = CStr(Int((16 * ee) / (3 * y)))
        frmjdt.Lab1.Caption = CStr(Int(h / y * 100)) & "%"
        frmjdt.Lab2.Caption = CStr(Int((100 * ee) / (3 * y))) & "%"
        DoEvents
   bs = Second(Now) '时间
   If bs - xs = 1 Then
      xs = bs
      ms = ms + 1
   Else
      If bs - xs = -59 Then
         xs = -1
      End If
   End If
 
   If ms = 60 Then
         ps = ps + 1
         ms = 0
   End If
   frmjdt.Label2.Caption = ps & "分" & ms & "秒"
   '时间
  
        With frmjdt.Im1
            .Width = h / y * 200
        End With
        With frmjdt.Im2
            .Width = (200 * ee) / (3 * y)
        End With
       
       
  h = h + 1
  ee = ee + 1
Loop

 

h = 8 '冲收帐
 frmjdt.Show
  frmjdt.Label1.Caption = "正在进行（二三）收入款项对帐，请稍候......"
Do While h <= y
  If Range("d" & h) <> "" Then
     k = 8
     Do While k <= y
        If Range("f" & k) <> "√" And Range("d" & h) = Range("g" & k) Then
              Range("c" & h) = "√"
              Range("f" & k) = "√"
              k = y
        End If
        k = k + 1
     Loop
  End If
        p = CStr(Int(h / y * 16))
        p2 = CStr(Int((16 * ee) / (3 * y)))
        frmjdt.Lab1.Caption = CStr(Int(h / y * 100)) & "%"
        frmjdt.Lab2.Caption = CStr(Int((100 * ee) / (3 * y))) & "%"
        DoEvents
   bs = Second(Now) '时间
   If bs - xs = 1 Then
      xs = bs
      ms = ms + 1
   Else
      If bs - xs = -59 Then
         xs = -1
      End If
   End If
 
   If ms = 60 Then
         ps = ps + 1
         ms = 0
   End If
   frmjdt.Label2.Caption = ps & "分" & ms & "秒"
    '时间
  
        With frmjdt.Im1
            .Width = h / y * 200
        End With
        With frmjdt.Im2
            .Width = (200 * ee) / (3 * y)
        End With
  h = h + 1
  ee = ee + 1
Loop

 
'传输数据

Sheets("未达帐项").Select
  
   Range("a6:d65536").Select
   Selection.ClearContents
   Range("a6").Select
  

Dim b, d, g, i, bb, dd, gg, ii, aaa, bbb, ccc, ddd, aaaa, bbbb, cccc, dddd
b = 8
d = 8
g = 8
i = 8

aaaa = 6
bbbb = 6
cccc = 6
dddd = 6
h = 8

 frmjdt.Show
 frmjdt.Label1.Caption = "正在传输未达帐项数据，请稍候......"

Do While h <= y

   Sheets("数据输入区").Select
  
  
   If Range("b" & b) <> "" And Range("a" & b) <> "√" Then
   Sheets("未达帐项").Range("a" & aaaa).Value = Sheets("数据输入区").Range("b" & b).Value
   aaaa = aaaa + 1
   End If
   b = b + 1
  
   
   If Range("d" & d) <> "" And Range("c" & d) <> "√" Then
     Sheets("未达帐项").Range("b" & bbbb).Value = Sheets("数据输入区").Range("d" & d).Value
     bbbb = bbbb + 1
   End If
  d = d + 1
 
 
 
   If Range("g" & g) <> "" And Range("f" & g) <> "√" Then
      Sheets("未达帐项").Range("c" & cccc).Value = Sheets("数据输入区").Range("g" & g).Value
      cccc = cccc + 1
   End If
   g = g + 1
 
 
   If Range("i" & i) <> "" And Range("h" & i) <> "√" Then
      Sheets("未达帐项").Range("d" & dddd).Value = Sheets("数据输入区").Range("i" & i).Value
     dddd = dddd + 1
   End If
   i = i + 1
   p = CStr(Int(h / y * 16))
   p2 = CStr(Int((16 * ee) / (3 * y)))
        frmjdt.Lab1.Caption = CStr(Int(h / y * 100)) & "%"
        frmjdt.Lab2.Caption = CStr(Int((100 * ee) / (3 * y))) & "%"
        DoEvents
       
   bs = Second(Now) '时间
   If bs - xs = 1 Then
      xs = bs
      ms = ms + 1
   Else
      If bs - xs = -59 Then
         xs = -1
      End If
   End If
 
   If ms = 60 Then
         ps = ps + 1
         ms = 0
   End If
   frmjdt.Label2.Caption = ps & "分" & ms & "秒"
    '时间
  
        With frmjdt.Im1
            .Width = h / y * 200
        End With
        With frmjdt.Im2
            .Width = (200 * ee) / (3 * y)
        End With
 
 h = h + 1
 ee = ee + 1
Loop
Unload frmjdt
MsgBox "对帐已经完成！请完成余额调节表！", vbOKOnly + 64, "完成"
 
 
 
End Sub

Sub Yjue_2()

 Sheets("数据输入区").Select
 Range("a8:d65536,f8:i65536").Select
 Selection.ClearContents
 Range("b8").Select
End Sub
Sub Yjue_3()

 Sheets("未达帐项").Select
 Range("a6:d65536").Select
 Selection.ClearContents
 Range("a6").Select
End Sub
Sub Yjue_4()
UserFormxg.Show
End Sub
Sub Yjue_5()

frmgy.Show
End Sub
Sub Yjue_6()
 On Error GoTo hhh
    Dim yhmc, zcsn, mmm
    Open ("c:\windows\system32\cmhzc.dll") For Input As #1
    Input #1, yhmc, zcsn
    Close
   
    MsgBox "软件已注册为" & yhmc, vbOKOnly + 48, "已注册"
   
    Exit Sub
   
hhh:
    frmzc.Show
End Sub

不知其中代码意思,

ysjfnkml

没人回答

[此贴子已经被作者于2006-11-7 16:23:07编辑过]

paul888

我也要哦!~

paul1109@163.com

gzy816

偶也想要啊

谢谢楼主

yuguowu@163.com

ychh_wy

可惜只有一对一的关系才能够配对，适用范围不理想

hnxpc

能告诉密码吗？谢谢！！！

xbay

楼主，我也要一份，谢谢。

b47@tom.com