日记首页  | 列表 | 添加日记  | 管理登陆  | 搜索 | 退出 直达底部 
****************************************
2002/1/18《日期格式统一》

经过网上咨询，解决了日期格式统一问题

http://club.excelhome.net/forum.php?mod=viewthread&tid=1412029&page=1#pid9503748
****************************************
2002/1/12《搜索-筛选代码》

Public Sub MySelRows()
Dim cnn, SQL$   '定义数据库连接和SQL语句
Set cnn = CreateObject("adodb.connection")  '创建数据库连接
Set rs = CreateObject("adodb.recordset")   '创建一个数据集保存数据
cnn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;HDR=yes;IMEX=2';data source=" & ThisWorkbook.FullName
SQL = "select * from  [sheet1$]  where 受理人 Like '%zuoxi%' Or 受理人 Like '&dudao%'"
Set rs = cnn.Execute(SQL)
Range("A2").CopyFromRecordset rs
Set cnn = Nothing
Set rs = Nothing

End Sub
Public Sub tt()
Set cnn = Nothing
Set rs = Nothing
End Sub






Sub 删除行() '数组
    Dim nRow&, m&, Arr(), Brr()
    With Sheet1
        nRow = .Range("a65536").End(xlUp).Row
        Arr = .Range("a2:g" & nRow).Value        '共有G列
        ReDim Brr(1 To nRow, 1 To 7)
        For i = 1 To nRow - 1
            If Arr(i, 5) Like "*zuoxi*" Or Arr(i, 5) Like "*dudao*" Then      '第*列筛选"zuoxi*" Or Arr(i, 5) Like "dudao*"
                m = m + 1
                For j = 1 To 7
                    Brr(m, j) = Arr(i, j)
                Next
            End If
        Next
        .Range("a2:g" & nRow).Value = Brr
    End With
End Sub
'忽略了大写


Sub 删除行2()
Dim c%, i%
c = Cells(Rows.Count, 5).End(3).Row     '取第*列第一次出现的非空单元格的行号
For i = c To 1 Step -1
If Cells(i, 5) Like "*否*" Then
Rows(i).Delete
End If
Next
End Sub
****************************************
2002/1/12《思路》

原来一直考虑：筛选出没有字符串（已完成）的数据。

突然想到：筛选出字符串（已完成）的数据，删除此行。


一下豁然开朗，有时要逆向思维，更要考虑更好的方案
****************************************
2002/1/9《工作计划完成表》

1. 苏媛的工作计划完成表，要设计VBA。实现查询

  • 把个人的汇总成一个文件  @---完成
  • 每个人一个文件夹，汇总时分别提取指定文件夹里的表格，然后重复下一个文件夹，以实现汇总所有  @---完成

2. 查询：

  • 日期查询（某一天所有人的）
  • 按人名查询（某人所有的）  @---完成
  • 按完成
  • 按未完成（所有的） @---完成
  • 指定时间（某天，某人）
  • 指定时间（某段）
  • 按未完成（某人的）
  • 按未完成（时间段）
  • 单元格完整显示（回车）

 
****************************************
2002/1/8《几个问题》

1.网页要修改：名称（华东销售额）

2.自动添加星期

3.搜索功能
****************************************
2018/4/18《查询所有人问题》

查询所有，单选任意年级，都ok，但要注意文件名顺序，否则错位。

组选出错。

组选初一、初二：初一无数据，初二显示正常；

组选初一、初三：初一无数据，初三语文显示历史数据（文件名称顺序）；

组选初二、初三：初二无数据，初三显示正常；
****************************************
2018/4/17《查询所有人》

有初一，初二和初三3个年级，3文件夹中分别各科课时记录。

现已实现，查询时，根据选择不同年级，提取并显示剩余课次（姓名右边第2列）。

希望增加：查询时，跳过没有上课的人（比如：李四）

思路：

 
****************************************
2018/3/30《思路问题》
思路的问题
在个人查询中，执行宏1
无法判断初一或初二等
干脆分三个子程序，初1初2初3?
Dim mypath
Sub 查询个人()
    t1 = UserForm查询窗体.CheckBox1.Value 'TextBox1
    t2 = UserForm查询窗体.CheckBox2.Value 'TextBox1    要注意指向窗体
    t3 = UserForm查询窗体.CheckBox3.Value
    If t1 = True And t2 = False And t3 = False Then
        t = UserForm查询窗体.CheckBox1.Caption: mypath = ThisWorkbook.Path & "\" & t & "\"
        Call 初1
    End If
    If t2 = True And t1 = False And t3 = False Then
        t = UserForm查询窗体.CheckBox2.Caption: mypath = ThisWorkbook.Path & "\" & t & "\"
        Call 初2
    End If
    If t3 = True And t1 = False And t2 = False Then
        t = UserForm查询窗体.CheckBox3.Caption: mypath = ThisWorkbook.Path & "\" & t & "\"
        Call 初3
    End If
End Sub
Sub 初1()
    Dim arr, brr, d, i&, j%
    Set d = CreateObject("scripting.dictionary")
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    wj = Dir(mypath & "*.xls*")
    Worksheets(1).Range("b3:c3").ClearContents
    Worksheets(1).Range("a4:c10000").ClearContents
    arr = Worksheets(1).Range("a1:v3")
    s = [{"数学","2";"语文","3"}]
    Do While wj <> ""
        If wj <> ThisWorkbook.Name Then
            With Workbooks.Open(mypath & wj)
            For n = 1 To UBound(s)
                If InStr(wj, s(n, 1)) Then
                    j = s(n, 2)
                End If
            Next
                brr = .Sheets(.Sheets.Count).UsedRange
                ncm = .Sheets(.Sheets.Count).Range("d1:aa1").Find(what:="姓名", lookat:=xlWhole).Column
                For i = 1 To UBound(brr)
                    d(brr(i, ncm)) = i
                Next
                For i = 1 To UBound(arr)
                    xm = Trim(UserForm查询窗体.TextBox1.Text)
                    If xm <> "" Then
                        If d.Exists(xm) Then
                            m = d(xm)
                            arr(3, 1) = xm
                            arr(3, j) = brr(m, ncm + 2)
                        Else
                            arr(3, j) = "/"
                        End If
                    End If
                Next
                d.RemoveAll
                .Close 0
            End With
        End If
        wj = Dir
    Loop
    Worksheets(4).Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
    Columns("A:G").AutoFit
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Sheet4.Activate
    Selection.Merge
    Range("A1:A2").Merge           'A1：A2合并
[A1].Value = "姓名"
[B1].Value = "数学"
[C1].Value = "语文"

   Dim t As Integer
   For t = 2 To 3
      Cells(2, t).Value = "剩余课时"  '用循环赋值“剩余课时”
   With Cells(2, t).Font           '设置单元格格式
      .Name = "宋体"
      .FontStyle = "bold"
      .Size = 12          '字体大小
      .ColorIndex = 12   '字体颜色
   End With
    Next
        ActiveSheet.UsedRange.Borders.LineStyle = 1  '对已用区域添加边框
    With Selection
        ActiveSheet.UsedRange.HorizontalAlignment = xlRight  '对已用区域左对齐
    End With
End Sub

Sub 初2()
    Dim arr, brr, d, i&, j%
    Set d = CreateObject("scripting.dictionary")
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    wj = Dir(mypath & "*.xls*")
    Worksheets(1).Range("b3:e3").ClearContents
    Worksheets(1).Range("a4:e10000").ClearContents
    arr = Worksheets(1).Range("a1:e3")
    s = [{"数学","2";"物理","3";"英语","4";"语文","5"}]
    Do While wj <> ""
        If wj <> ThisWorkbook.Name Then
            With Workbooks.Open(mypath & wj)
            For n = 1 To UBound(s)
                If InStr(wj, s(n, 1)) Then
                    j = s(n, 2)
                End If
            Next
                brr = .Sheets(.Sheets.Count).UsedRange
                ncm = .Sheets(.Sheets.Count).Range("d1:aa1").Find(what:="姓名", lookat:=xlWhole).Column
                For i = 1 To UBound(brr)
                    d(brr(i, ncm)) = i
                Next
                For i = 1 To UBound(arr)
                    xm = Trim(UserForm查询窗体.TextBox1.Text)
                    If xm <> "" Then
                        If d.Exists(xm) Then
                            m = d(xm)
                            arr(3, 1) = xm
                            arr(3, j) = brr(m, ncm + 2)
                        Else
                            arr(3, j) = "/"
                        End If
                    End If
                Next
                d.RemoveAll
                .Close 0
            End With
        End If
        wj = Dir
    Loop
    Worksheets(4).Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
    Columns("A:G").AutoFit
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Sheet4.Activate
    Selection.Merge
    Range("A1:A2").Merge           'A1：A2合并
[A1].Value = "姓名"
[B1].Value = "数学"
[C1].Value = "物理"
[D1].Value = "英语"
[E1].Value = "语文"
   Dim t As Integer
   For t = 2 To 5
      Cells(2, t).Value = "剩余课时"  '用循环赋值“剩余课时”
   With Cells(2, t).Font           '设置单元格格式
      .Name = "宋体"
      .FontStyle = "bold"
      .Size = 12          '字体大小
      .ColorIndex = 12   '字体颜色
   End With
    Next
        ActiveSheet.UsedRange.Borders.LineStyle = 1  '对已用区域添加边框
    With Selection
        ActiveSheet.UsedRange.HorizontalAlignment = xlRight  '对已用区域左对齐
    End With
End Sub
Sub 初3()
    Dim arr, brr, d, i&, j%
    Set d = CreateObject("scripting.dictionary")
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    wj = Dir(mypath & "*.xls*")
    Worksheets(1).Range("b3:g3").ClearContents
    Worksheets(1).Range("a4:g10000").ClearContents
    arr = Worksheets(1).Range("a1:g3")
    s = [{"数学","2";"物理","3";"英语","4";"语文","5";"历史","6";"化学","7"}]
    Do While wj <> ""
        If wj <> ThisWorkbook.Name Then
            With Workbooks.Open(mypath & wj)
            For n = 1 To UBound(s)
                If InStr(wj, s(n, 1)) Then
                    j = s(n, 2)
                End If
            Next
                brr = .Sheets(.Sheets.Count).UsedRange
                ncm = .Sheets(.Sheets.Count).Range("d1:aa1").Find(what:="姓名", lookat:=xlWhole).Column
                For i = 1 To UBound(brr)
                    d(brr(i, ncm)) = i
                Next
                For i = 1 To UBound(arr)
                    xm = Trim(UserForm查询窗体.TextBox1.Text)
                    If xm <> "" Then
                        If d.Exists(xm) Then
                            m = d(xm)
                            arr(3, 1) = xm
                            arr(3, j) = brr(m, ncm + 2)
                        Else
                            arr(3, j) = "/"
                        End If
                    End If
                Next
                d.RemoveAll
                .Close 0
            End With
        End If
        wj = Dir
    Loop
    Worksheets(4).Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
    Columns("A:G").AutoFit
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Sheet4.Activate
    'Call 合并单元格指定位置
    'Call 写入单元格课时查询
    'Call 复制
    'Call 边框线
    Call 抬头目录        '组合了上面4个模块
End Sub
****************************************
2018/3/26《vba问题》
查询如何按需要显示
思路：可以显示后删除
  共有日记399篇，每页10篇，分40/40页   9首页 3上页 下页4  尾页: