[已解决]跪求大神来段分表代码

339356416

小弟工作遇到麻烦。附件内表格上级要求一户一表。就是把附件里面的每张表格单独提取出来变成独立的EXCEL表格，再命名成户主名字，附件只是一部分，还有几千个农户的表格要弄，跪求大神帮忙，可不可以给段代码一次性搞定的？

最佳答案

月排行榜 / 总排行榜

wenzili

2017-3-18 14:16

Public Sub qq()
Dim rgn As Range
Dim name1 As String
Dim m As String
Dim n As Long
Dim wb As Workbook
Dim snamefile As String
Dim i As Long
n = 1
Application.ScreenUpdating = False



For Each rgn In ThisWorkbook.Sheets("1").UsedRange
    If rgn.Value = "户主" Then
        name1 = rgn.Offset(0, -2)
    End If
   
    If rgn.Value Like "*调查记事：填写：1）承包方代表变更情况；*" Then
        If n = 1 Then
            n = rgn.Row
            m = "1" & ":" & n
        Else
            m = n + 1 & ":" & rgn.Row
            n = rgn.Row
        End If
    snamefile = ThisWorkbook.Path & "\" & name1 & ".xlsx"
    Set wb = Workbooks.Add
    ThisWorkbook.Sheets("1").Rows(m).Copy Sheets("sheet1").Range("a1")
    If nameexists(snamefile) Then
        i = 0
        Do
        i = i + 1
        snamefile = ThisWorkbook.Path & "\" & name1 & i & ".xlsx"
        Loop While nameexists(snamefile)
    End If
        
        wb.SaveAs Filename:=snamefile
    wb.Close
    End If
Next

Application.ScreenUpdating = True


End Sub




Public Function nameexists(sname As String) As Boolean
If Dir(sname) <> "" Then
nameexists = True
End If


End Function
考虑户主重名情况，重名后再名字后加数字序列号

跳转到最佳答案楼层

339356416

有人吗

wenzili

Public Sub qq()
Dim rgn As Range
Dim name1 As String
Dim m As String
Dim n As Long
Dim wb As Workbook
n = 1
Application.ScreenUpdating = False



For Each rgn In ThisWorkbook.Sheets("1").UsedRange
    If rgn.Value = "户主" Then
        name1 = rgn.Offset(0, -2)
    End If
   
    If rgn.Value Like "*调查记事：填写：1）承包方代表变更情况；*" Then
        If n = 1 Then
            n = rgn.Row
            m = "1" & ":" & n
        Else
            m = n + 1 & ":" & rgn.Row
            n = rgn.Row
        End If
    Set wb = Workbooks.Add
    ThisWorkbook.Sheets("1").Rows(m).Copy Sheets("sheet1").Range("a1")
    wb.SaveAs ThisWorkbook.Path & "\" & name1 & ".xlsx"
    wb.Close
    End If
Next

Application.ScreenUpdating = True


End Sub
文件增加到代码所在工作簿目录。
源文件格式有变化，不是固定行数，所以以表格最后一行作为结束判断。如确保每个表的最后一行一致，可以正确拆分。
没有考虑户主重名情况

wenzili

Public Sub qq()
Dim rgn As Range
Dim name1 As String
Dim m As String
Dim n As Long
Dim wb As Workbook
Dim snamefile As String
Dim i As Long
n = 1
Application.ScreenUpdating = False



For Each rgn In ThisWorkbook.Sheets("1").UsedRange
    If rgn.Value = "户主" Then
        name1 = rgn.Offset(0, -2)
    End If
   
    If rgn.Value Like "*调查记事：填写：1）承包方代表变更情况；*" Then
        If n = 1 Then
            n = rgn.Row
            m = "1" & ":" & n
        Else
            m = n + 1 & ":" & rgn.Row
            n = rgn.Row
        End If
    snamefile = ThisWorkbook.Path & "\" & name1 & ".xlsx"
    Set wb = Workbooks.Add
    ThisWorkbook.Sheets("1").Rows(m).Copy Sheets("sheet1").Range("a1")
    If nameexists(snamefile) Then
        i = 0
        Do
        i = i + 1
        snamefile = ThisWorkbook.Path & "\" & name1 & i & ".xlsx"
        Loop While nameexists(snamefile)
    End If
        
        wb.SaveAs Filename:=snamefile
    wb.Close
    End If
Next

Application.ScreenUpdating = True


End Sub




Public Function nameexists(sname As String) As Boolean
If Dir(sname) <> "" Then
nameexists = True
End If


End Function
考虑户主重名情况，重名后再名字后加数字序列号

339356416

wenzili 发表于 2017-3-18 14:16
Public Sub qq()
Dim rgn As Range
Dim name1 As String

太厉害了 谢谢大神。省了我好多事