VBA如何把家庭成员的竖排变为横排

shibenting

VBA如何把家庭成员的竖排变为横排？  在本网站论坛我也遇到这个歌帖子，但是和我需要的有很大的不同，而且又不会修改代码。希望各位大神帮帮，写个代码，下来我再细细研究。谢谢！

一把小刀闯天下

Option Explicit

Sub test()
  Dim i, j, k, a, m, n, arr
  With Sheets("源数据")
    arr = .Range("a2:m" & .Cells(Rows.Count, "a").End(xlUp).Row + 1)
  End With
  ReDim brr(1 To UBound(arr, 1), 1 To 10 * UBound(arr, 2)) As String '一个家庭最多10人，自己修改
  For i = 1 To UBound(arr, 1) - 1
    For j = i To UBound(arr, 1) - 1
      If arr(j + 1, 9) = "户主" Or Len(arr(j + 1, 9)) = 0 Then
        n = n + 1: m = 0
        For a = i To j
          For k = 1 To UBound(arr, 2)
            m = m + 1: brr(n, m) = arr(a, k)
        Next k, a
        i = j: Exit For
      End If
  Next j, i
  With Sheets("新表").[a2]
    .Resize(Rows.Count - 1, UBound(brr, 2)).ClearContents
    If n > 0 Then .Resize(n, UBound(brr, 2)) = brr
  End With
End Sub

shibenting

一把小刀闯天下 发表于 2018-6-20 11:29
Option Explicit

Sub test()

太感谢你了，找了两年了，前两个月才发现本论坛有，看不懂vba代码，才匆匆去学，结果学了一个多月，还是看不懂，更是修改不了代码。  今天谢谢你的帮忙。

ggmmlol

一把小刀闯天下 发表于 2018-6-20 11:29
Option Explicit

Sub test()

三层循环，还可以更简化一些。而且，为了避免身份证号码最后几位变0，宜把存放结果的数组声明为字符串类型：

1. Sub test()
   
2. Dim r&, ar, c&, br$(), i&, hh$, n&, k&, j&
   
3. r = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row
   
4. ar = Sheet2.Range("A1:M1").Resize(r)
   
5. c = UBound(ar, 2)
   
6. ReDim br(1 To r \ 3, 1 To c * 10)
   
7. hh = ar(1, 3)
   
8. For i = 2 To r
   
9.     If ar(i, 3) <> hh Then
   
10.         hh = ar(i, 3): n = n + 1: k = 0
    
11.     End If
    
12.     For j = 1 To c
    
13.         k = k + 1: br(n, k) = ar(i, j)
    
14.     Next
    
15. Next
    
16. Sheet9.[a2].Resize(n + 1, c * 10) = br
    
17. End Sub

复制代码

jjmysjg

留下记号。谢谢

shibenting

ggmmlol 发表于 2018-6-21 01:24
三层循环，还可以更简化一些。而且，为了避免身份证号码最后几位变0，宜把存放结果的数组声明为字符串类 ...

非常感谢你们的回答，两个代码我拿去研究一下。

h2016

家庭户籍横竖切换

全党

字典加数组处理