库存表自动操作编程

'事件

Private Sub change_header_Click()
'把输入框中的内容更换掉选择的表头
    replace_header
End Sub

 

Private Sub CommandButton1_Click()
'显示帮助
    show_help
End Sub

Private Sub input_month_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
'在月按回车,转到日
    If KeyCode = 13 Then input_day.Activate
End Sub

Private Sub input_day_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
'在日按回车,转到备注
    If KeyCode = 13 Then input_more.Activate
End Sub

Private Sub input_more_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
'在备注按回车,转到入数
    If KeyCode = 13 Then input_in_num.Activate
End Sub

Private Sub input_in_num_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
'在入数按回车,转到入价
    If KeyCode = 13 Then input_in_price.Activate
End Sub

Private Sub input_in_price_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
'在入价按回车,转到出数
    If KeyCode = 13 Then input_out_num.Activate
End Sub

Private Sub input_out_num_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
'在出数按回车,转到出价
    If KeyCode = 13 Then input_out_price.Activate
End Sub

Private Sub input_out_price_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
'在出价按回车,转到表名
    If KeyCode = 13 Then list_input.Activate
End Sub

Private Sub list_input_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
'在查找按tab,转到插入
    If KeyCode = 9 Then input_ok.Activate
End Sub

Private Sub input_ok_Click()
'插入数据
    input_data 1, 0
End Sub

Private Sub input_reset_Click()
'清空输入数据
    retset_input
End Sub

Private Sub list_input_Change()
'改变输入就选择列表
    select_list (list_input)
End Sub

 

Private Sub list_name_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
'双击定位
    get_cell (1)
End Sub

Private Sub list_input_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
'ctrl+回车,直接跳转过去
    'MsgBox (KeyAscii)
    If KeyAscii = 10 Then get_cell (1) '10 是CTRL+ENTER 13是enter
End Sub

Private Sub list_name_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'列表框中点右键,
    If Button = 2 Then flash_list
End Sub

Private Sub list_name_Click()
'点击列表取得表名,
    If list_name_click_event.Value = True Then list_input = list_name.Value
End Sub

 

'函数

Sub replace_header()
'把输入框中的内容更换掉选择的表头
    If Trim(list_input) = "" Then
        MsgBox ("请在左边输入框中输入新表头后再试")
        Exit Sub
    End If
   
    If list_name.ListIndex < 1 Then
        MsgBox ("请选择要替换的表头后再试")
        Exit Sub
    End If
   
    Dim text, table, row, cell
    text = list_name.List(list_name.ListIndex, 0)
    row = Int(list_name.List(list_name.ListIndex, 2))
    cell = Int(list_name.List(list_name.ListIndex, 3))
    table = list_name.List(list_name.ListIndex, 1)
   
    If MsgBox("你确定把表头" & Chr(10) & list_name.List(list_name.ListIndex, 0) & Chr(10) & " 替换成 " & Chr(10) & list_input, vbYesNo) = vbYes Then
               
        If InStr(1, comment_text(ThisWorkbook.Worksheets(table).cells(row, cell)), list_title.Value, 1) > 0 Then
            ThisWorkbook.Worksheets(table).cells(row, cell).Value = list_input
            MsgBox ("替换完成!请检查" & "因为刚才进行了表头替换操作,请重新刷新表头列表")
            list_name.Clear
        Else
            MsgBox ("出错!" & Chr(10) & "现在选中的单元格不是表头,因为它没有包含批注:" & list_title.Value)
        End If
       
        focus_cell table, row, cell
    End If
End Sub

Sub reset_input()
'清空输入备插入数据
   
    input_month = ""
    input_day = ""
    input_more = ""
    input_in_num = ""
    input_in_price = ""
    input_out_num = ""
    input_out_price = ""
End Sub

Function input_data(ByVal insert, ByVal reset As Integer)
'插入所有的数据,insert =0时清空,这些数据有,月,日,备注,入数,入价,出数,出价

    Dim cell, val_cell, temp, error, msg '7个单元格
    cell = get_cell(0)
    If UBound(cell) <> 2 Then
        MsgBox ("请在上面表头列表中,选择你要操作的表头,注意第一条列表不能选择,那是提示作用")
        Exit Function
    End If
   
    If Trim(input_more) = "" Then
        MsgBox ("备注不能留空")
        Exit Function
    End If
   
    val_cell = Array(Array(input_month, month_cell), Array(input_day, month_2_day), Array(input_more, month_2_more), Array(input_in_num, month_2_in_num), Array(input_in_price, month_2_in_price), Array(input_out_num, month_2_out_num), Array(input_out_price, month_2_out_price))                         '月,日,备注,入数,入价,出数,出价
        error = 0
       
        For temp = 0 To UBound(val_cell)
            If set_value(cell, val_cell(temp)(0), val_cell(temp)(1)) = 1 Then
                error = error + 1 '错误次数
                set_color cell, 3, val_cell(temp)(1) '红色字体标志
            Else
                set_color cell, 5, val_cell(temp)(1)
            End If
        Next
     
       msg = ""
       If error Then msg = "发现" & error & "处错误!" & Chr(10) & Chr(10) & Chr(10) & "部分要插入数据单元格已存在数据,放弃插入,并用红色字体标志,请检查" & Chr(10) & Chr(10)
       If view.Value Then msg = msg & "数据全部处理完成,请检查"
   
    If (view.Value = True) Or error Then focus_cell cell(0), cell(1), cell(2) '激活单元格
    If msg <> "" Then MsgBox (msg)
   
    If clear_color.Value = True Then
    '清除亮色
        For temp = 0 To UBound(val_cell)
            set_color cell, 0, val_cell(temp)(1)
        Next
    End If
End Function

Sub set_color(ByVal cell, ByVal light, ByVal month_2)
'设置色
    If (ThisWorkbook.Worksheets(cell(0)).cells(cell(1), cell(2) + month_2).Font.ColorIndex <> 3) Then '3是红色,不取消
        ThisWorkbook.Worksheets(cell(0)).cells(cell(1), cell(2) + month_2).Font.ColorIndex = light
    End If
End Sub

Function set_value(ByVal cell, ByVal insert, ByVal month_2)
'设置值,insert传入值就写入数据,但是会检查是否有值,有值就出错提示
       set_value = 0
   
       If Trim(ThisWorkbook.Worksheets(cell(0)).cells(cell(1), cell(2) + month_2).Value) <> "" Then
       '非空,出错
            set_value = 1
       Else
         ThisWorkbook.Worksheets(cell(0)).cells(cell(1), cell(2) + month_2).Value = insert
       End If
End Function

Public Sub flash_list()
'刷新厂名,药品,规格列表
  
    list_name.Clear '清空所有
    Dim blank_4_end
    blank_4_end = 20 '空内容几行就表示后面是结束了,
   
    If Trim(list_title.Value) = "" Then
        MsgBox ("请指定写有药品名.厂家.规格单元格的批注里面的内容")
        Exit Sub
    End If
   
   
    If (Trim(list_row.Value) = "") Or (Not IsNumeric(list_row)) Then
        MsgBox ("请指定写有药品名.厂家.规格单元格在第几行")
        Exit Sub
    End If
   
    Dim for_i, blank_4_end_l, list_a, new_val, list_a_copy, array_l, copy_i, for_i_i, table_i
    blank_4_end_l = 0
    for_i = 1
    list_a = Array()
    table_i = 1 '表下标,个数从1开始
       
    Do
       
        If InStr(1, comment_text(ThisWorkbook.Worksheets(table_i).cells(list_row.Value, for_i)), list_title.Value, 1) > 0 Then
            '找到有此批注的单元格
                new_val = ThisWorkbook.Worksheets(table_i).cells(list_row.Value, for_i).Value
            '排序
                array_l = UBound(list_a)
                copy_i = 0
                 ReDim list_a_copy(array_l + 1, 3)
               
                If array_l < 0 Then
                    ReDim list_a(0, 3)
                    list_a(0, 0) = new_val '名
                    list_a(0, 1) = list_row.Value '行
                    list_a(0, 2) = for_i '列
                    list_a(0, 3) = ThisWorkbook.Worksheets(table_i).Name '表名
                Else
                    For for_i_i = 0 To array_l
                        '复制并插入新值,并检查是否有重复
                       ' MsgBox ("for_i_i=" & for_i_i & " array_l=" & array_l & " list_a=" & UBound(list_a) & " list_a(for_i_i, 0) = " & list_a(for_i_i, 0))
                       
                        If new_val = list_a(for_i_i, 0) Then
                            '重复了,不允许
                            MsgBox ("列举表名失败!发现有二个相同的表名,这是不允许的请修正后再试!" & Chr(10) & "它们分别是:" _
                            & Chr(10) & "表名:" & ThisWorkbook.Worksheets(list_a(for_i_i, 3)).Name & Chr(10) _
                            & Chr(10) & "单元格" & Replace(ThisWorkbook.Worksheets(list_a(for_i_i, 3)).cells(list_row.Value, list_a(for_i_i, 2)).Address, "$", "") _
                            & " = " & ThisWorkbook.Worksheets(list_a(for_i_i, 3)).cells(list_row.Value, list_a(for_i_i, 2)) _
                            & Chr(10) & "表名:" & ThisWorkbook.Worksheets(table_i).Name & Chr(10) _
                            & Chr(10) & "单元格" & Replace(ThisWorkbook.Worksheets(table_i).cells(list_row.Value, for_i).Address, "$", "")) _
                            & " = " & ThisWorkbook.Worksheets(table_i).cells(list_row.Value, for_i)
                            Exit Sub
                        ElseIf (new_val <> "") And (new_val < list_a(for_i_i, 0)) Then
                            list_a_copy(copy_i, 0) = new_val '名
                            list_a_copy(copy_i, 1) = list_row.Value '行
                            list_a_copy(copy_i, 2) = for_i '列
                            list_a_copy(copy_i, 3) = ThisWorkbook.Worksheets(table_i).Name '表名
                            copy_i = copy_i + 1
                            list_a_copy(copy_i, 0) = list_a(for_i_i, 0) '名
                            list_a_copy(copy_i, 1) = list_a(for_i_i, 1) '行
                            list_a_copy(copy_i, 2) = list_a(for_i_i, 2) '列
                            list_a_copy(copy_i, 3) = list_a(for_i_i, 3) '表名
                            new_val = ""
                        Else
                            list_a_copy(copy_i, 0) = list_a(for_i_i, 0) '名
                            list_a_copy(copy_i, 1) = list_a(for_i_i, 1) '行
                            list_a_copy(copy_i, 2) = list_a(for_i_i, 2) '列
                            list_a_copy(copy_i, 3) = list_a(for_i_i, 3) '表
                            If (new_val <> "") And (for_i_i = array_l) Then
                             copy_i = copy_i + 1
                            list_a_copy(copy_i, 0) = new_val '名
                            list_a_copy(copy_i, 1) = list_row.Value '行
                            list_a_copy(copy_i, 2) = for_i '列
                            list_a_copy(copy_i, 3) = ThisWorkbook.Worksheets(table_i).Name '表名
                            End If
                        End If
                        copy_i = copy_i + 1
                    Next
   
                    list_a = list_a_copy
                End If
                '排序
        End If
       
       
        for_i = for_i + 1
        Err.Clear
       
        If for_i > 256 Then  '有些版本的e表最大列是256个;
            If table_i < ThisWorkbook.Worksheets.Count Then
            '查找完本表,查找下个表
                table_i = table_i + 1
                for_i = 1
                blank_4_end_l = 0
            Else
            '查找完所有的表,退出
                Exit Do
            End If
        Else '256判断
       
             If VarType(ThisWorkbook.Worksheets(table_i).cells(list_row.Value, for_i)) = 0 Then
                 blank_4_end_l = blank_4_end_l + 1 '注意此,别死环
             Else
                 blank_4_end_l = 0 '注意此,别死环
             End If
       
              If blank_4_end_l > blank_4_end Then
                If table_i < ThisWorkbook.Worksheets.Count Then
                   '查找完本表,查找下个表
                       table_i = table_i + 1
                       for_i = 1
                       blank_4_end_l = 0
               
                Else
                     '查找完所有的表,退出
                      Exit Do
                End If
              End If
       
        End If '256判断
       
    Loop
  
   
        list_name.AddItem ("表头名称(共有" & UBound(list_a) + 1 & "个药品名列表)") '增加一个提示
        list_name.List(0, 1) = ("表名") '记录表
        list_name.List(0, 2) = ("行号") '记录行
        list_name.List(0, 3) = ("列号") '记录列
   
   
    For for_i = 0 To UBound(list_a)
    '把表名列到box中
        list_name.AddItem (list_a(for_i, 0))  '记录表名,二个参数,参数1是列表名,参数二是添加时的下标,空表示加到最后,二个参数时不能使用括号
        list_name.List(for_i + 1, 2) = list_a(for_i, 1) '记录行
        list_name.List(for_i + 1, 3) = list_a(for_i, 2) '记录列
        list_name.List(for_i + 1, 1) = list_a(for_i, 3) '记录表名
    Next
End Sub

Public Function select_list(ByVal str)
    '选择列表
    select_list = -1
   
    If auto_find.Value = False Then Exit Function
   
    If list_name.ListCount < 1 Then
        MsgBox ("药品列表是空的,请先创建表格好后(不需要增加时可以不创建),在列表框点击右键来生成")
        Exit Function
    End If
   
    If Trim(str) = "" Then
     '空白,不查找
         intoview 0
         Exit Function
    End If
   
    Dim for_i, select_i, last_match
    select_i = list_name.ListIndex '当前选中的列表,没选中返回-1,第一条列表是0,使用value也可以
    If select_i = -1 Then select_i = 0
   
    If (select_i > 0) Then
        If (InStr(1, list_name.List(select_i, 0), str, 1) > 0) And (InStr(1, list_name.List(select_i - 1, 0), str, 1) < 1) Then
           select_list = select_i
           Exit Function '当前选中匹配，向前匹配，退出
         End If
   
         last_match = -1
   
        For for_i = select_i - 1 To 0 Step -1
        '向上查找,从上一个开始
            If InStr(1, list_name.List(for_i), str, 1) > 0 Then
                last_match = for_i
            ElseIf last_match > -1 Then
                Exit For '找到，再向前就找不到，必须回滚
            End If
        Next
   
        If last_match > -1 Then
            select_list = last_match
            intoview last_match
            Exit Function
        End If
    End If
   
    For for_i = select_i To (list_name.ListCount - 1)
    '向下查找,从当前开始
        If InStr(1, list_name.List(for_i), str, 1) > 0 Then
            last_match = for_i
            Exit For
        End If
    Next
  
   If last_match > -1 Then
    select_list = last_match
    intoview last_match
    Exit Function
   Else
    '找不到
    intoview 0
    select_list = -1
   End If
End Function

Public Function comment_text(ByVal cell_obj)
'获取单元格标签内容
     comment_text = ""
     On Error Resume Next
     comment_text = cell_obj.Comment.text '有标签的
     On Error GoTo 0
End Function

Public Function get_cell(ByVal focus As Integer)
    '定位到表的可输入的空行
    '注意,as 前传入的值必须类型一样
    get_cell = Array()
   
    If list_name.ListIndex < 1 Then
    '未选择,或选择了提示
        Exit Function
    End If
   
    Dim row, cell, text, table_name
    text = list_name.List(list_name.ListIndex, 0)
    row = list_name.List(list_name.ListIndex, 2)
    cell = list_name.List(list_name.ListIndex, 3)
    table_name = list_name.List(list_name.ListIndex, 1)
   
    cell = Int(cell)
    row = Int(row)
   
    If (Trim(ThisWorkbook.Worksheets(table_name).cells(row, cell)) = "") Or (ThisWorkbook.Worksheets(table_name).cells(row, cell) <> text) Then
        MsgBox ("无法定位!单元格" & Replace(ThisWorkbook.Worksheets(table_name).cells(row, cell).Address, "$", "") _
        & "内容已不再是:" & text & "; 可能是被修改过了,请重新刷新列表再试")
        Exit Function
    End If
   
    Dim for_i, cell_o
    for_i = CInt(month_row.text) + row
    cell = CInt(month_cell.text) + cell
   
    Do
        for_i = for_i + 1 '注意必须加加,要不死
        If for_i > 10000 Then '防死
            MsgBox ("中止查找单元格" & Replace(ThisWorkbook.Worksheets(table_name).cells(row, cell).Address, "$", "") _
            & text & "表的空白可输入数据的新行,因为本表的行数已超过了10000行.此表过大,建议制作一个新的excel文件来使用.")
            Exit Function
        End If
               
        If Trim(ThisWorkbook.Worksheets(table_name).cells(for_i, cell).Value) = "" Then Exit Do '发现了空行就跳出
       
    Loop
   
   
    If focus Then focus_cell table_name, for_i, cell
    get_cell = Array(table_name, for_i, cell) '返回表名,行,列
   
End Function

Sub focus_cell(ByVal table_name As String, ByVal row As Integer, ByVal cell As Integer)
'激活单元格
    ThisWorkbook.Worksheets(table_name).Activate
    ThisWorkbook.Worksheets(table_name).cells(row, cell).Activate '再选中返回
End Sub

Private Sub Worksheet_Activate()
    '禁止滚动,把此标控制在单元格1内
    ActiveSheet.ScrollArea = "A1"
End Sub

Sub intoview(ByVal index)
'选中并滚动到可见处
    list_name.TopIndex = index
    list_name.Selected(index) = True
End Sub

Sub show_help()
'显示帮助
    MsgBox (" " _
                    & " 在表头表(文字边的右边大框),占右键刷新所有表的表头,双击转到可填写内容单元格;" & Chr(10) _
                    & "表头点击开:选了,点击表头表列表,列表名字自动输入到查找框中;" & Chr(10) _
                    & "自动匹配开:选了,查找输入内容自动匹配选中表头中列表,不存在选中第一个" & Chr(10) _
                    & "查找:输入内容匹配表头用,按tab键自动跳到插入按钮,ctrl+enter直接跳到表头中选中的表的可输入空白月份单元格" & Chr(10) _
                    & "替换表头:用查找中内容替换掉选中的表头,替换后,需要重新右键刷新表头" & Chr(10) _
                    & "月,日,备注,入库数量,单价,出库数量,单价对应单元格中的空白输入单元格,用于填写新数据,这些输入框回车自动跳到下个框,最后的单价回车跳到查找,输入完成后,点击插入即可,清空用于把这些框清空,消色,选了,提示过后,蓝色字自动变回黑色,查看,选了,插入完成会跳到该行" & Chr(10) _
                    & "月份偏离表头列数:月的第一个可输入单元格离本表头列数,一般是0,月份空行:从整个表首行算起,空白可输入的月份的单元格行数;" & Chr(10) _
                    & "日偏月列数,备注偏月列,入数偏月列,入价偏月列,出数偏月列,出价偏月列:表示这些跟月份输入单元格的同行可输入单元格分别偏离月份单元多少列" & Chr(10) _
                    & "表头批注:表头必须包含的批注内容关键字;表头行号:表头单元格所在的行" & Chr(10) _
                    & "工作溥中可以插入任意个数的表,且名字可以随便,但是输入操作控制面板这个表一定要包含,否则无法使用这些自动处理功能,最好备份一个空白内容的工作溥用于后面使用,以免要清空数据麻烦" & Chr(10) _
                    & "" & Chr(10) _
    & " ")
End Sub

 

 

 

 

 

 

 

 

 

 

---------------------

 

 

http://cid-0c051e9a0a1fd5a3.office.live.com/embedicon.aspx/xp/%e5%ba%93%e5%ad%98%e8%a1%a8.xls

下载链接