excel 做数据源的经典问题征解

Question

一个excel表做数据源，表头为（序号、编号、姓名、性别、年龄、单位），表可能存在以下问题：
1、序号可能不连续或重复
2、编号首字母可能为0，被认作了数字
3、有重复人员登记（编号、姓名相同）
4、性别有空缺的
5、年龄有录入出生日期或出生年月的，或excel不认识的日期的（如80.5.6或80、5或80年5月或80。5。6）
6、单位有同一个单位两种名称的
现在要用VB做一个统计程序，以该表为数据源，如何进行数据有效性校验，要求
1、第一个问题可直接重新编序号，可省略
2、第2、3、4、5出现问题，以提示框告知问题记录行
3、第5项最好能自动变成年龄要求大于15，小于65
4、全部通过后，以提示框显示单位列表，提醒是否需要更改部分单位名称那位大侠能给出代码，感激不尽，这个问题应用应该很广泛，我是冲着这个问题来CSDN注册的，不要说使用或先转换成access，因为熟悉excel的人远多于用access的，报上来的都是excel表，我是新手，粗通VB，只有边查边看的水平，自己实在写不出，拜托！！！，本人E-mail：[email protected]

Answer 1

一个白天无人应答，快要沉了，问题难度应该不算大，但有点麻烦，是吧！ 
补充问题： 
1、序号可能不连续或重复       
2、编号首字母可能为0，被认作了数字       
3、有重复人员登记（编号、姓名相同）       
4、性别有空缺的       
5、年龄有录入出生日期或出生年月的，或excel不认识的日期的（如80.5.6或80、5或80年5月或80。5。6）       
6、单位有同一个单位两种名称的       
7、表中间可能有空行 现在要用VB对数据进行有效性校验，要求       
1、第一个问题可直接重新编序号，可省略       
2、第2、3、4、5出现问题，以提示框告知问题记录行       
3、第5项最好能自动变成年龄要求大于15，小于65       
4、全部通过后，以提示框显示单位列表，提醒是否需要更改部分单位名称       
 
 
 

Answer 2

对此表的有效性校验只是第一步，接下来要录入每个人的资料，进行统计，出具报告。 因为表是别人报上来的，不能事先设置，而且该表可能连字段名称、字段多少都不一定，所以手工更改是一定要做的，但手工更改后，仍可能存在上面6种情况，另加2个情况：1、可能有空的字段（没报上来），2、有空的行（记录）。 我要的程序主要功能是“检测-提示存在错误格式”。 这个问题较难的地方：1、要把“年龄”字段中，可能不规范的日期格式自动更改为数字。2、显示单位列表。3、有重复人员登记 我认为要以excel做数据源，这个问题应该很有代表性，一定要解决，不是吗？ 

Answer 3

Dim xlbook As Object
Dim xlsheet As Object
dim i,m,n,p as integer
dim bh,xm as string
Set xlbook = Nothing
Set xlsheet = Nothing
Set xlbook = GetObject(EXCE文档所在路径及文件名)　　‘这里你可以作一个commondalog
xlsheet=xlbook.Worksheets(工作表名)
i=2
do until xlsheet.cell(i,1).value=""     '当序号为空时就停下来了。
if xlsheet.cell(i+1,1).value＜＞i-1 then
xlsheet.cell(i,1).value=i
endif                                   '序号修改完成if left(xlsheet.cell(i,2).value)="0"  then   '如果编号单元格内的数据的第一个数字为0　然后……
代码　　　　　　　　　　　　　　　　　　　　　　　　　　其实你的意思我不太明白，编号首字母可能为0被认作了数字
endifbh=xlsheet.cell(i,2).value
xm=xlsheet.cell(i,3).value
m=2
n=0 
p=0     
do untill xlsheet.cell(m,1).value=""
if bh=xlsheet.cell(m,2).value then
n=n+1
endif
if xm=xlsheet.cell(m,3).value then
p=p+1
endifif n=2 or p=2 then
msgbox "出现了编号重复或姓名重复，问题出在第"　& m & "行"
endif
m=m+1
loopif xlsheet.cell(i,4).value="" then
msgbox "性别出现空值，问题出现在第"　& i &　"行" 
endif
。
。
。
。
。
。
i=i+1
loop第56我就不清楚了。第7个同上
另外这里判断的表结束标志是序号行为空时就停止，这个可能也会有问题，你可能根据具体情况具体对待。
我没有试试，你可以参考这个思路！

Answer 4

问题过多 分数太少~！   所以没人答~！
          jiangsheng曾经写过难的 繁琐的问题就要高分别人解决了要给高分，没解决要给辛苦分

Answer 5

我也想知道excel做数据库的问题，access是什么都不知道，无从下手，也没看过access软件

Answer 6

问题太麻烦又没有分，所以特别感谢能给予回答的黑领兄弟！excel太强大，都被它惯着了，要不是它，我现在应该对数据库非常熟悉了，身边的人们也是这样，所以只好顺势而为，用它来做数据源，但这样出现一个问题－－数据定义不准确，所以在统计分析之前，需要对表中所有数据进行有效性检验，我的问题由此而来，这也是该问题具有的普遍意义所在，不是吗？看来我的描述有一定问题，有人没看懂，我怕说细了，没人能耐住性子看完，我再拣重点说说：报上来的excel表头为（序号、编号、姓名、性别、年龄、单位），我要以它为基础，录入每个人的其他资料（有30项以上），而且有一部分人在表中没有，另有一部分人在表中有却没有用，表可能存在以下问题：2、“编号”本应是字符串，在excel表中，以“0”开头的输入成了以“'0”开头（未定义单元格格式，怕被认作了数字）5、“年龄”有录入出生日期或出生年月的，或excel不认识的日期的（如80.5.6或80、5或80年5月）               6、“单位”字段中有同一个单位，出现两种名称的，如有的是“一厂”，有的是“采油一厂”实际是同一个。我要求：1、要把“年龄”字段中，可能不规范的日期格式自动更改为数字，错误日期格式更改不完全不要紧，因为一次通不过，就提示手工更改，直到全部通过为止。2、校验通过后，要求显示一个“单位”列表，就是要把excel表经“自动筛选”后出现的哪个下拉列表提取出来，提示给录入人员，看是否有需要修改的，别的方面我吭哧个十天半个月也许能有笨办法解决，但这个最困扰我。              向看完问题并明白了我的意思的人致敬！

Answer 7

你的问题不用VB解决，EXCEL自代的VBA就可以完美解决。还有看你的介绍，EXCEL自身带有的一些功能你也没用到，实际EXCEL你也不是高手！

Answer 8

我那句话说自己是excel高手了？统计分析部分用vba做过，我的最终目的是完成一个能自动出具分析报告的独立程序，所以必须用vb完成，楼上的“高手”帮我把“要求2”解决下吧！不管是vb还是vba，你的留言除了废话还是废话。

Answer 9

年龄字段的判断（接上面的），也是笨办法，参考吧：
dim nl as integer　　　　　　＇声明一个变量用来存放年龄的．
if   len(xlsheet.cell(i,５).value)=2 then
   if xlsheet.cell(i,５).value<=15 or xlsheet.cell(i,５).value>=65 then
       msgbox "年龄应该在１５－６５之间＂　　　　　＇这里你可以根据自己的情况加一些语句
　　endif
else  '如果不是2位，也就是说输入的不是年龄，下在来判断日期格式．因为ＶＢ默认是yy-mm-dd那我们就按这个判断．
  
　　if mid(xlsheet.cell(i,５).value,3,1)<>"-" then  '判断第三个字符是不是"-"这个思路你试试，不行再改改．
       msgbox "年龄的日期格式不是yy-mm-dd,请修正！"      
　　else
      ln =（date-xlsheet.cell(i,５).value）／３６５      
      xlsheet.cell(i,５).valuen=nl  '计算年龄
    endif
endif单位判断，大体思路，你看行不行得通：判断单位的数据是不是只有２位，如果是，再从单位列第一个数据中取前两位对比，如果不相同，向后取，如，对比＂一厂＂，第一个人的单位是＂石油一厂＂，第一次从＂石油一厂＂中取＂石油＂是否于＂一厂＂，不是，再取＂油一＂，不是，再向后取＂一厂＂．相等了．这两个数据就被认为是相同的单位！

Answer 10

瞅空给你写了个示例，大概思路而已，自己根据需要完善吧：
    Dim oExcel As Object
    Dim oBook As Object
    Dim oSheet As Object
    Dim oRange As Object
    Dim arrData As Variant
    Dim r As Integer, c As Integer
    Dim row As Integer
    Dim i As Integer
    Dim tmp As String, tmpData As String
    
On Error GoTo App_Err:    Set oExcel = CreateObject("Excel.Application")
    Set oBook = oExcel.Workbooks.Open("C:\t.xls")
    Set oSheet = oBook.Worksheets(1)
    oSheet.Activate
     
    '获得已使用的行列
    r = oSheet.UsedRange.Cells.Rows.Count
    c = oSheet.UsedRange.Cells.Columns.Count
    
    '将内容读入数组
    ReDim arrData(1 To r, 1 To c)
    '序号、编号、姓名、性别、年龄、单位
    arrData = oSheet.Range("A1").Resize(r, c)
    
    '处理数据：
    For row = 2 To r
        '序号
        arrData(row, 1) = row - 1
        '编号
        arrData(row, 2) = Format(arrData(row, 2), "0000")
        '性别
        arrData(row, 4) = IIf(Trim(Format(arrData(row, 4))) <> "", _
            arrData(row, 4), "女")      '性别为空的都设置为“女”
        '年龄
        arrData(row, 5) = Replace(arrData(row, 5), ".", "/")
        arrData(row, 5) = Replace(arrData(row, 5), "、", "/")
        arrData(row, 5) = Replace(arrData(row, 5), "-", "/")
        arrData(row, 5) = Format(arrData(row, 5), "yy年mm月dd日")
        arrData(row, 5) = DateDiff("yyyy", arrData(row, 5), Date) '得到年龄
        '单位
        arrData(row, 6) = Replace(arrData(row, 6), "一厂", "采油一厂") '自己根据需要添加
    Next
    '相同记录保存在文本文件中
    tmpData = "序号" & vbTab & "编号" & vbTab & "姓名" & vbCrLf
    For i = 2 To UBound(arrData) - 1
        tmp = arrData(i, 2) & vbTab & arrData(i, 3)
        For row = i + 1 To UBound(arrData)
            If arrData(row, 2) & vbTab & arrData(row, 3) = tmp Then
                tmpData = tmpData & arrData(row, 1) & vbTab & tmp & vbCrLf
            End If
        Next row
    Next i
    Open "C:\tmp.txt" For Output As #1
        Print #1, tmpData
    Close #1
    
    '定义单元格格式
    oExcel.Columns("B:D").Select
    oExcel.Selection.NumberFormatLocal = "@"
    '写回excel表格
    oSheet.Range("A1").Resize(r, c).Value = arrData
    oBook.Save
    
    MsgBox "ok"
    oBook.Close
App_Exit:
    Set oSheet = Nothing
    Set oBook = Nothing
    oExcel.Quit
    Set oExcel = Nothing
    Exit Sub
App_Err:
    MsgBox Err.Description
    Resume App_Exit

Answer 11

一个excel表，第一行是字段名，选“数据”→“筛选”→“自动筛选”，会在每个字段名旁边出现下拉列表，列出该列中所有不同内容，如何提取到一个数组中？

Answer 12

“自动筛选”内容的提取Sub noRepeatList()
Dim UniqueValue As New Collection
Dim u As Variant
On Error Resume Next
irow = Sheet1.[A65536].End(xlUp).Row
Set rng = Sheet1.Range("a1:a" & irow)
    
For Each cel In rng
UniqueValue.Add cel.Value, CStr(cel.Value)
Next celFor Each u In UniqueValue
If Sheet1.Cells(1, 6) = "" Then
  Sheet1.Cells(1, 6) = u
  Else: Sheet1.Cells(1, 6) = Sheet1.Cells(1, 6) & "、" & u
End If
Next u
End Sub