VBA替代人工一键整理下载的数据格式
工作中遇到不提供导出exel表,但又需要导出Excel表打印核对,怎么办呢?自己复制粘贴,删除不用的,改格式是一种办法,但数据太多的话就麻烦了。高手可以用爬虫,但万一犯法呢,不会弄,也不敢弄。所以就复制粘贴后vba代替人工整理格式,备忘。
先简要说下步骤:
步骤1 打开网页或者app,全选复制,粘着到txt中,然后下一页,再全选复制粘贴到txt中,这样把所有的数据保存为了纯文本。
步骤2 全选txt中的数据,复制粘贴到Excel第一列中。
步骤3 添加按钮,双击编写处理数据的代码。执行一下看结果,不对就调试下,改改代码就ok了。
下面分析下我们看粘贴来的内容(都改成了假信息做例子,避免泄露个人信息),每个人都有身份证,后六位是******非常容易判断,话身份证上面依次是地址、电话、姓名,我只要这四个信息。
从第一行到最后一行遍历,用if判断,如果单元格最后六位是“******”,就用变量m累加记录第几个人。用数据a(m)记录下行号,行号依次减1、2、3就是地址、电话、姓名。再用循环写入2-5列就可以了。代码如下,都有注释。
Private Sub CommandButton1_Click()
Dim arr() As String '定义数组
Dim erow As Long, xcount As Long '定义变量
erow = ActiveSheet.Range("A65535").End(xlUp).Row '设置erow为第列最后一个使用的单元格
xcount = Application.WorksheetFunction.CountIf(Range(Cells(2, 1), Cells(erow, 1)), "*~*~*~*~*~*~*") '调用函数contif计算最后六位为******的个数,为了重新定义arr()数组用。
ReDim arr(1 To xcount) '重定义数组
m = 1 '数组索引号
For i = 1 To erow
If Right(Cells(i, 1), 6) = "******" Then '判断后六位是******
arr(m) = i '数组arr()中记录身份证再第一列的行号
m = m + 1 '累加人员个数
End If
Next
For j = 1 To xcount '用for循环写从第二行开始写,345列分别是姓名、电话、地址、身份证
Cells(j + 1, 2) = Cells(arr(j) – 3, 1)
Cells(j + 1, 3) = Cells(arr(j) – 2, 1)
Cells(j + 1, 4) = Cells(arr(j) – 1, 1)
Cells(j + 1, 5) = Cells(arr(j), 1)
Next
End Sub
执行下代码,发现大部分正确,因为有的人信息也不全,格式就乱了,除了身份证外位置就不对了。
直接改很难想,整理后就很容易找规律了。先修改姓名的位置,若果第二列最后三个字是“村委会”,他右面的那一列就是姓名,挪过来就可以了。再看电话,电话都是11位的,如果地址栏的长度是11,就是电话,挪到电话那一栏就可以了。
因为自己水平有限,循环变量用i,j习惯了,就写个小程序嵌套下,避免变量重复。
Sub St2()
erow = ActiveSheet.Range("B65535").End(xlUp).Row '设置erow位第二列最后一个使用的单元格
For i = 2 To erow '循环判断第二列最后3个字如果是"村委会",就将右面的内容移古来,原来的删除.
If Right(Cells(i, 2).Value, 3) = "村委会" Then
Cells(i, 2) = Cells(i, 3)
Cells(i, 3) = ""
End If
Next
For j = 2 To erow '循环判断第4列长度是否为11,是就将内容给左边,原来的删除.
Cells(j, 6) = Cells(j, 2) & Left(Cells(j, 5), 12) '顺道合并下姓名和身份证,以后电脑核对用.
If Len(Cells(j, 4)) = 11 Then
Cells(j, 3) = Cells(j, 4)
Cells(j, 4) = ""
End If
Next
End Sub
最后再commond1的代码endsub前,加上St2,就能一键执行过来了。
这样就基本实现一键整理格式,核对就不成问题了。如果还是有极个别的错误,就自己手动调整下吧。
如若转载,请注明出处:https://www.daxuejiayuan.com/3345.html