学生的学籍卡，都在一个WORD文件中，用VBA方法可以快速提取学生的各种信息到EXCEL...

liyongjin · 发表于 2024-9-10 16:54

学籍卡文件中是所有少于的学籍卡，每个学生一页。有快速方法提取相关信息到信息表中吗？希望高手指点。

limonet · 发表于 2024-9-10 17:03

类似的案例很多，先搜索一下。

kevinchengcw · 发表于 2024-9-10 17:16

Sub test()
Dim Rule, Rule2, N&, I&, R&, C&, Obj, S$
Rule = Array(2, 2, 2, 4, 2, 6, 3, 2, 3, 6, 9, 2, 10, 2)
Rule2 = Array(2, 2, 2, 3, 3, 2, 3, 3)
R = 1
With GetObject(ThisWorkbook.Path & "\学生学籍卡 (1).doc")
For Each Obj In .tables
C = 0: R = R + 1
For N = LBound(Rule) To UBound(Rule) Step 2
If N = UBound(Rule) - 1 Then
With Obj.cell(Rule(N), Rule(N + 1)).tables(1)
For I = LBound(Rule2) To UBound(Rule2) Step 2
S = .cell(Rule2(I), Rule2(I + 1)).Range.Text
C = C + 1: Cells(R, C).Value = Left(S, Len(S) - 2)
Next I
End With
Else
S = Obj.cell(Rule(N), Rule(N + 1)).Range.Text
C = C + 1: Cells(R, C).Value = Left(S, Len(S) - 2)
End If
Next N
Next Obj
.Saved = True
.Close
End With
Columns.AutoFit
End Sub

复制代码

chxw68 · 发表于 2024-9-10 18:11

Sub test()
Dim r%, i%, m%
Dim arr, brr()
Dim mypath$, myname$
Dim myapp As Object
Dim mydoc As Object
mypath = ThisWorkbook.Path & ""
myname = "学生学籍卡.doc"
If Dir(mypath & myname) = "" Then
MsgBox mypath & myname & "不存在！"
Exit Sub
End If
Set myapp = CreateObject("word.application")
Set mydoc = CreateObject("word.document")
myapp.Visible = True
Set mydoc = myapp.Documents.Open(Filename:=mypath & myname)
With mydoc
ReDim brr(1 To .tables.Count, 1 To 10)
For k = 1 To .tables.Count
With .tables(k)
brr(k, 1) = Replace(.cell(2, 2).Range.Text, Chr(13) & Chr(7), Empty)
brr(k, 2) = Replace(.cell(2, 4).Range.Text, Chr(13) & Chr(7), Empty)
brr(k, 3) = Replace(.cell(2, 6).Range.Text, Chr(13) & Chr(7), Empty)
brr(k, 4) = Replace(.cell(3, 2).Range.Text, Chr(13) & Chr(7), Empty)
brr(k, 5) = Replace(.cell(3, 6).Range.Text, Chr(13) & Chr(7), Empty)
brr(k, 6) = Replace(.cell(5, 2).Range.Text, Chr(13) & Chr(7), Empty)
With .cell(10, 2).tables(1)
For i = 2 To .Rows.Count
x = 0
Select Case Left(.cell(i, 1).Range.Text, 2)
Case "父亲"
x = 7
Case "母亲"
x = 9
End Select
If x <> 0 Then
brr(k, x) = Replace(.cell(i, 2).Range.Text, Chr(13) & Chr(7), Empty)
brr(k, x + 1) = Replace(.cell(i, 3).Range.Text, Chr(13) & Chr(7), Empty)
End If
Next
End With
End With
Next
End With
mydoc.Close False
myapp.Quit
With Worksheets("sheet1")
.UsedRange.Offset(1, 0).Clear
.Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
End With
End Sub

复制代码

chxw68 · 发表于 2024-9-10 18:12

练习。。。

liyongjin · 发表于 2024-9-10 19:47

chxw68 发表于 2024-9-10 18:12
练习。。。

感谢，下来我认真学习学习。

liyongjin · 发表于 2024-9-10 20:35

本帖最后由 liyongjin 于 2024-9-10 20:37 编辑

kevinchengcw 发表于 2024-9-10 17:16

父母姓名电话有的互换了？怎么处理？

wang-way · 发表于 2024-9-10 21:35

liyongjin 发表于 2024-9-10 20:35
父母姓名电话有的互换了？怎么处理？

那就再做一次判断呗

wang-way · 发表于 2024-9-10 21:37

现在学籍卡里写个代码测试一下，各项内容所处的单元格序号，方便定位提取信息。第38个是表中表，这个表可以直接根据行列索引去读取。

wang-way · 发表于 2024-9-10 21:50

不考虑效率只考虑实现结果

Sub GetData()
Set wb = Application.ThisWorkbook
Set sht = wb.Worksheets(1)
fd = wb.Path & ""
i = 1 '第一行是表头，数据从第二行开始
Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(fd).Files
For Each f In fs
fn = f.Name
fp = f.Path
If fp Like "*学籍卡*.doc*" And Not fp Like "*~*" Then
Debug.Print fp
Set doc = GetObject(fp)
For Each tb In doc.tables
i = i + 1
s = tb.Range.Cells(3).Range.Text
sht.Cells(i, 1).Value = Left(s, Len(s) - 2)
s = tb.Range.Cells(5).Range.Text
sht.Cells(i, 2).Value = Left(s, Len(s) - 2)
s = tb.Range.Cells(7).Range.Text
sht.Cells(i, 3).Value = Left(s, Len(s) - 2)
s = tb.Range.Cells(10).Range.Text
sht.Cells(i, 4).Value = Left(s, Len(s) - 2)
s = tb.Range.Cells(14).Range.Text
sht.Cells(i, 5).Value = Left(s, Len(s) - 2)
s = tb.Range.Cells(28).Range.Text
sht.Cells(i, 6).Value = Left(s, Len(s) - 2)
Set tb2 = tb.Range.Cells(38).tables(1)
If tb2.cell(2, 1).Range.Text Like "*父亲*" Then
s = tb2.cell(2, 2).Range.Text
sht.Cells(i, 7).Value = Left(s, Len(s) - 2)
s = tb2.cell(2, 3).Range.Text
sht.Cells(i, 8).Value = Left(s, Len(s) - 2)
s = tb2.cell(3, 2).Range.Text
sht.Cells(i, 9).Value = Left(s, Len(s) - 2)
s = tb2.cell(3, 3).Range.Text
sht.Cells(i, 10).Value = Left(s, Len(s) - 2)
Else
s = tb2.cell(2, 2).Range.Text
sht.Cells(i, 9).Value = Left(s, Len(s) - 2)
s = tb2.cell(2, 3).Range.Text
sht.Cells(i, 10).Value = Left(s, Len(s) - 2)
s = tb2.cell(3, 2).Range.Text
sht.Cells(i, 7).Value = Left(s, Len(s) - 2)
s = tb2.cell(3, 3).Range.Text
sht.Cells(i, 8).Value = Left(s, Len(s) - 2)
End If
Next tb
doc.Close False
End If
Next
End Sub

复制代码

		自动登录	找回密码
密码			免费注册