- Sub lqxs()
- Dim Arr, i&, Myr&, Brr, r%, Arr1(), ks, js, j&, n&, c%
- Sheet1.Activate
- [c2:e20000].ClearContents
- Myr = [a65536].End(xlUp).Row
- Arr = Range("a2:a" & Myr)
- ReDim Brr(1 To UBound(Arr), 1 To 3)
- For i = 1 To UBound(Arr)
- If Left(Arr(i, 1), 2) = "名字" Then
- r = r + 1
- ReDim Preserve Arr1(1 To r)
- Arr1(r) = i
- End If
- Next
- For i = 1 To r
- If i <> r Then
- js = Arr1(i + 1) - 1
- Else
- js = UBound(Arr)
- End If
- ks = Arr1(i)
- n = n + 1: c = 0
- For j = ks To js
- If Arr(j, 1) <> "" Then
- c = c + 1
- Brr(n, c) = Arr(j, 1)
- End If
- Next
- Next
- [c2].Resize(n, 3) = Brr
- End Sub
复制代码 |