只提取表格中指定内容到WORD中

yjwdjfqb

只提取表格中指定内容到WORD中

现在的代码是全部人员提取到，WORD中
想修改成，只提取妻子，或者丈夫的信息到WORD表格中，即每个人的配偶

请老师们帮修改下，谢谢老师了!


附件.rar (25.61 KB, 下载次数: 10)

2019-12-8 12:17 上传

点击文件名下载附件

logo28

增加一个选择妻子或丈夫的条件,然后判断数据行是否包含关键字:妻子或者丈夫就可以了.增加代码:
    sel = Val(Application.InputBox("请输入要导出的数据类型:" & vbCrLf & vbCrLf & "妻子:1" & vbCrLf & "丈夫:2", "提示"))
    seltxt = Application.WorksheetFunction.Choose(sel, "妻子", "丈夫")
后面输出数据的代码改为:
                '*************************************************************************
                If Trim(Cells(Target.Row, "E")) <> "" Then
                    renArr = Split(Cells(Target.Row, "E"), vbLf)
                    For hs = 0 To UBound(renArr)
                        If InStr(renArr(hs), seltxt) Then
                        re = Split(renArr(hs), ",")
                        hs = 0
                        .Tables(2).Cell(hs + 5, 2).Range.Text = re(0)
                        .Tables(2).Cell(hs + 5, 3).Range.Text = re(1)
                        .Tables(2).Cell(hs + 5, 4).Range.Text = Format(re(2), "yyyy.mm")
                        .Tables(2).Cell(hs + 5, 5).Range.Text = re(3)
                        .Tables(2).Cell(hs + 5, 6).Range.Text = re(4)
                        Exit For
                        End If
                    Next hs
                End If
                '*************************************************************************

yjwdjfqb

logo28 发表于 2019-12-18 20:13
增加一个选择妻子或丈夫的条件,然后判断数据行是否包含关键字:妻子或者丈夫就可以了.增加代码:
    sel =  ...

老师你好，你那儿修改好的附件发了好吧，我没有修改对呢，谢谢你了老师！

logo28

test.zip (15.65 KB, 下载次数: 8)

2019-12-18 20:25 上传

点击文件名下载附件

yjwdjfqb

logo28 发表于 2019-12-18 20:25

把这二句
sel = Val(Application.InputBox("请输入要导出的数据类型:" & vbCrLf & vbCrLf & "妻子:1" & vbCrLf & "丈夫:2", "提示"))
    seltxt = Application.WorksheetFunction.Choose(sel, "妻子", "丈夫")
改成下面这样，怎么改呀老师，谢谢你了！


MyNa = InputBox("请输入要导出的类型,多项类型中间用顿号分隔", "提示", "妻子、丈夫")

logo28

你是要同时选择两个类型的话,就用你改的,后面要分割一下

yjwdjfqb

logo28 发表于 2019-12-18 20:43
你是要同时选择两个类型的话,就用你改的,后面要分割一下

    MyNa = InputBox("请输入要导出的类型,多项类型中间用顿号分隔", "提示", "妻子、丈夫")

    seltxt = Split(renArr(MyNa), "、")
我这样，不行呢，老师帮我修改下好吧，谢谢了！

logo28

Sub test()
    Dim rng As Range
    Dim xml As Range
    Dim Emp As Range
    Dim Target As Range
    Dim pic As String
    Dim objWord As Object
    Dim strPath$
    Dim hs As Integer
    Dim mbName, renArr
    Dim MyNa As String, seltxt
    Set objWord = CreateObject("word.application")
    strPath = ThisWorkbook.Path & Application.PathSeparator
    Sheets("数据").Select
    Set xml = Worksheets("数据").Range("C:C")
    On Error Resume Next
    Set rng = Application.InputBox("请选择数据" & vbCrLf & vbCrLf & "可按CTRL键选择不连续的人员", "提示", , Type:=8)
    MyNa = InputBox("请输入要导出的类型,多项类型中间用顿号分隔", "提示", "妻子、丈夫")
    seltxt = Split(MyNa, "、")
    If rng Is Nothing Then Exit Sub
    If Application.Intersect(xml, rng).Count <> rng.Count Then MsgBox "非法选区,程序退出！", vbInformation + vbOKOnly, "提示": Exit Sub
    For Each Emp In rng
        If IsEmpty(Emp) Then MsgBox "选择区有空单元格": Exit Sub
    Next Emp
    With objWord
        For Each Target In rng
           'With .Documents.Add(Template:=strPath & "模板-可选择操作.doc")
            With .Documents.Add(Template:=strPath & "模板" & ".doc")
                Application.StatusBar = "正在处理 " & Cells(Target.Row, "c")
                .bookmarks("姓名").Range.Text = Cells(Target.Row, "c")
               
               
               
               
                '*************************************************************************
                If Trim(Cells(Target.Row, "E")) <> "" Then
                    renArr = Split(Cells(Target.Row, "E"), vbLf)
                    For hs = 0 To UBound(renArr)
                        If InStr(renArr(hs), seltxt(0)) Or InStr(renArr(hs), seltxt(1)) Then
                        re = Split(renArr(hs), ",")
                        hs = 0
                        .Tables(2).Cell(hs + 5, 2).Range.Text = re(0)
                        .Tables(2).Cell(hs + 5, 3).Range.Text = re(1)
                        .Tables(2).Cell(hs + 5, 4).Range.Text = Format(re(2), "yyyy.mm")
                        .Tables(2).Cell(hs + 5, 5).Range.Text = re(3)
                        .Tables(2).Cell(hs + 5, 6).Range.Text = re(4)
                        Exit For
                        End If
                    Next hs
                End If
                '*************************************************************************
               
               
               
                .SaveAs strPath & Cells(Target.Row, "c") & ".doc", FileFormat:=0
                '.SaveAs strPath & Cells(Target.Row, "a") & "." & Cells(Target.Row, "c") & ".doc", FileFormat:=0
                .Close True
            End With
        Next
        .Quit
    End With
    Application.StatusBar = ""
    MsgBox "恭喜您！整理完成。", , "提示"
End Sub

logo28

完整代码已发,贴进模块里自行调试