偏移提取

SCWYZJ

请老师帮忙看看，这效果怎样实现！我想提取出来方便打印！谢谢！

ww87725244

1. =SMALL(IFERROR(0/(($C$3:$M$22=O$2)*$B$3:$L$22)+($C$3:$M$22=O$2)*$B$3:$L$22,""),ROW(A1))
   
2. 三键

复制代码

鄂龙蒙

1. Sub 统计()
   
2.     Dim ar, br(), cr(), m, n, i, j
   
3.     Range("T3:U10000").ClearContents
   
4.     ar = Range("B2").CurrentRegion
   
5.         For j = 1 To UBound(ar, 2) Step 2
   
6.             For i = 2 To UBound(ar)
   
7.                 If ar(i, j) <> "" Then
   
8.                     If ar(i, j + 1) = "住人" Then
   
9.                         m = m + 1
   
10.                         ReDim Preserve br(1 To m)
    
11.                         br(m) = ar(i, j)
    
12.                     ElseIf ar(i, j + 1) = "空房" Then
    
13.                         n = n + 1
    
14.                         ReDim Preserve cr(1 To n)
    
15.                         cr(n) = ar(i, j)
    
16.                     End If
    
17.                 End If
    
18.             Next
    
19.         Next
    
20.     [T3].Resize(m, 1) = Application.Transpose(br)
    
21.     [U3].Resize(n, 1) = Application.Transpose(cr)
    
22. End Sub

复制代码

abc123281

1. Sub test()
   
2. Dim arr, brr(1 To 10000, 1 To 1), crr(1 To 10000, 1 To 1)
   
3. With Worksheets("sheet1")
   
4.     r = .Cells.SpecialCells(xlCellTypeLastCell).Row
   
5.     arr = .Range("b3:m" & r)
   
6.     For j = 1 To UBound(arr, 2)
   
7.       For i = 1 To UBound(arr)
   
8.         If arr(i, j) = "住人" Then
   
9.           n = n + 1
   
10.           brr(n, 1) = arr(i, j - 1)
    
11.         ElseIf arr(i, j) = "空房" Then
    
12.           m = m + 1
    
13.           crr(m, 1) = arr(i, j - 1)
    
14.         End If
    
15.       Next
    
16.     Next
    
17. .[o3].Resize(n, 1) = brr
    
18. .[p3].Resize(m, 1) = crr
    
19. End With
    
20. End Sub

复制代码

abc123281

这效果可怎样实现123.rar (17.48 KB, 下载次数: 4)

2018-5-23 21:29 上传

点击文件名下载附件

扑腾

1. Sub 查房()
   
2. Application.ScreenUpdating = False
   
3.     Dim r&, i%, k%, m%, n%
   
4.     [o3:p2000].ClearContents
   
5.     r = Cells.Find("*", , , , 1, 2).Row
   
6.     m = [o2000].End(xlUp).Row
   
7.     n = [p2000].End(xlUp).Row
   
8.     For k = 3 To 13 Step 2
   
9.         For i = 3 To r
   
10.             If Cells(i, k) = "住人" Then
    
11.                 Cells(m + 1, "o") = Cells(i, k - 1)
    
12.                 m = m + 1
    
13.             ElseIf Cells(i, k) = "空房" Then
    
14.                 Cells(n + 1, "p") = Cells(i, k - 1)
    
15.                 n = n + 1
    
16.             End If
    
17.         Next i
    
18.     Next k
    
19. Application.ScreenUpdating = True
    
20. End Sub
    

复制代码

SCWYZJ

abc123281  扑腾二位真是厉害！佩服！谢谢1