用vba把行转成列

yufan427

各位老师好！怎么用VBA把sheet1中的行转换成列，按照户号及家庭成员转，结果输出在sheet2中。

ahnyt

你的源文件的列是固定的还是不固定的

bbm000000

Sub i()
Dim i, ar, br(1 To 65536, 1 To 100), s, k, n
ar = [a1].CurrentRegion
For i = 2 To UBound(ar, 1)
If ar(i, 1) <> "" Then
s = s + 1
br(s, 1) = ar(i, 1)
m = 0
k = 0
Else
m = m + 1
k = m * 5
End If
br(s, 2 + k) = ar(i, 2)
br(s, 3 + k) = ar(i, 3)
br(s, 4 + k) = ar(i, 4)
br(s, 5 + k) = ar(i, 5)
br(s, 6 + k) = ar(i, 6)
If m > n Then n = m
Next
[i2].Resize(s, n * 5 + 6) = br
End Sub
写的不好莫怪

fxl447098457

bbm000000 发表于 2017-12-5 09:21
Sub i()
Dim i, ar, br(1 To 65536, 1 To 100), s, k, n
ar = [a1].CurrentRegion

你的只是输出了户主的信息。没有输出其他成员的信息。。

microyip

序号100的家庭明明是5口，怎么变成了家庭人口是4呢？难道其中一个不是人？

bbm000000

fxl447098457 发表于 2017-12-5 09:34
你的只是输出了户主的信息。没有输出其他成员的信息。。

请仔细看下

ahnyt

看看这个结果如何？

fxl447098457

bbm000000 发表于 2017-12-5 09:40
请仔细看下

看了下，楼主是要得到Sheet2的结果，你好像反过来了。。

Chip_Kenny

try this:

1. Sub zz()
   
2. Application.ScreenUpdating = 0
   
3. Dim ar, xm$, a, b(), n&
   
4. xm = Right(Sheets(1).[b1], 2)
   
5. ar = Sheets(1).UsedRange
   
6. For j = 1 To UBound(ar, 2)
   
7.     If InStr(ar(1, j), xm) Then a = a & "|" & j
   
8. Next
   
9. a = Split(a, "|")
   
10. ReDim b(1 To (UBound(ar) - 1) * UBound(a) + 1, 1 To 6)
    
11. For j = 1 To 6
    
12.     b(1, j) = ar(1, j)
    
13. Next
    
14. n = 1
    
15. For i = 2 To UBound(ar)
    
16.     n = n + 1
    
17.     For j = 1 To 6
    
18.         b(n, j) = ar(i, j)
    
19.     Next
    
20.     For j = 1 To UBound(a)
    
21.         If Len(ar(i, a(j))) Then
    
22.             n = n + 1
    
23.             For jj = 0 To 2
    
24.                 b(n, jj + 2) = ar(i, a(j) + jj)
    
25.             Next
    
26.             b(n, 5) = ar(i, 5): b(n, 6) = ar(i, 6)
    
27.         End If
    
28.     Next
    
29. Next
    
30. Workbooks.Add 1
    
31. [a1].Resize(n, 6) = b
    
32. Application.ScreenUpdating = 1
    
33. End Sub

复制代码

一把小刀闯天下

Option Explicit

Sub test()
  Dim i, arr, brr, n, j, k
  arr = Sheets("sheet1").[a1].CurrentRegion
  ReDim brr(1 To 16 ^ 4, 1 To 6)
  For i = 2 To UBound(arr, 1)
    n = n + 1:
    For j = 1 To 6: brr(n, j) = arr(i, j): Next
    For j = 7 To UBound(arr, 2) Step 3
      If Len(Trim(arr(i, j))) = 0 Then Exit For
      n = n + 1
      For k = 2 To 4: brr(n, k) = arr(i, j + k - 2): Next
    Next
  Next
  With Sheets("sheet2")
    .Columns(1).Resize(, UBound(brr, 2)).ClearContents
    .[a1].Resize(1, UBound(brr, 2)) = arr
    .[a2].Resize(n, UBound(brr, 2)) = brr
  End With
End Sub