家庭成员合并求助

0oo清风oo0

将A、D、E、F、H列按G列的家庭成员合并，合并后格式见附表

与户主关系【本人】为间隔




谢谢了


户主合并.rar (15.29 KB, 下载次数: 43)

2018-9-25 11:57 上传

点击文件名下载附件

鄂龙蒙

1. Sub 家庭成员合并()
   
2.     Dim d, ar, br(), m, i, j, s
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     ar = Range("A1").CurrentRegion
   
6.         For i = 4 To UBound(ar)
   
7.             If ar(i, 7) = "本人" Then
   
8.                 s = ar(i, 2)
   
9.                 If d(s) = "" Then
   
10.                     m = m + 1: ReDim Preserve br(1 To 3, 1 To m)
    
11.                     d(s) = m: br(1, m) = s: br(2, m) = i
    
12.                 End If
    
13.             End If
    
14.         Next
    
15.         For i = 1 To UBound(br, 2) - 1: br(3, i) = br(2, i + 1) - 1: Next
    
16.     br(3, m) = UBound(ar): sa = Array(1, 4, 5, 6, 8)
    
17.     Application.DisplayAlerts = False
    
18.         For i = 1 To UBound(br, 2)
    
19.             For j = 0 To 4: Range(Cells(br(2, i), sa(j)), Cells(br(3, i), sa(j))).Merge: Next
    
20.         Next
    
21.     Application.DisplayAlerts = True
    
22.     Application.ScreenUpdating = True
    
23.     Set d = Nothing
    
24. End Sub

复制代码

一把小刀闯天下

Option Explicit

Sub test()
  Dim i, j, p, pos
  pos = Array(1, 4, 5, 6, 8)
  Call doevent(False)
  With Sheets("原数据")
    p = 4
    .Cells(4, "c").Resize(.Cells(Rows.Count, "b").End(xlUp).Row - 3).ClearContents
    For i = 4 To .Cells(Rows.Count, "b").End(xlUp).Row
      If Cells(i + 1, "g") = "本人" Or Len(Cells(i + 1, "g")) = 0 Then
        For j = 0 To UBound(pos)
          .Cells(p, pos(j)).Resize(i - p + 1).Merge
        Next
        p = i + 1
        If .Cells(i + 2, "g") <> "本人" Then i = i + 1
      End If
    Next
  End With
  Call doevent(True)
End Sub

Function doevent(flag)
  With Application
    .ScreenUpdating = flag
    .DisplayAlerts = flag
  End With
End Function

0oo清风oo0

朱荣兴 发表于 2018-9-25 12:37
没有明显的判断标志，很难做到，
像这类信息，应该会有个  户号   吧，根据户号来合并就简单多了

有明显的判断标志，【本人】

fyure

设个flag

hzruziniu

1. Sub yyy()
   
2.     Dim r%,i%
   
3.     Application.DisplayAlerts = False
   
4.     r = Range("a65536").End(3).Row
   
5.     For i = 4 To r
   
6.         If Cells(i, "G").Value <> "本人" Then
   
7.             Range(Cells(i - 1, 1), Cells(i, 1)).Merge
   
8.             Range(Cells(i - 1, 4), Cells(i, 4)).Merge
   
9.         End If
   
10.     Next
    
11.     Application.DisplayAlerts = True
    
12. End Sub

复制代码

0oo清风oo0

fyure 发表于 2018-9-25 13:47
设个flag

非常感谢·，，学习了·

不知道为什么

忙了一天，终于可以上来转转了。

凑个热闹：

不知道为什么

方法二，好像这样更容易理解