[已解决]求助vba

fghji

条件提取.rar (21.66 KB, 下载次数: 24)

2013-7-3 17:34 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

suye1010

2013-7-3 17:55

1. Sub ExtractData()
   
2. Dim arr, d, Sht, i As Integer, j As Integer
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. For Each Sht In ThisWorkbook.Sheets
   
5.     arr = Sht.Range("G1:CX" & Sht.Range("G65536").End(xlUp).Row)
   
6.         For i = 14 To UBound(arr) - 3 Step 17
   
7.             For j = 1 To UBound(arr, 2)
   
8.                 If CStr(arr(i, j)) = CStr(arr(i + 1, j)) And CStr(arr(i, j)) = CStr(arr(i + 2, j)) Then
   
9.                     d("表" & Sht.Name & "-" & Sht.Cells(i + 3, j + 6).Address(0, 0)) = "表" & Sht.Name & "-" & Sht.Cells(i + 3, j + 6).Address(0, 0)
   
10.                 End If
    
11.             Next j
    
12.         Next i
    
13.     Erase arr
    
14. Next
    
15. ThisWorkbook.Sheets("1").Cells(1, 1).Resize(d.Count, 1) = Application.Transpose(d.keys)
    
16. End Sub

复制代码

条件提取.rar (27.64 KB, 下载次数: 2)

2013-7-4 13:51 上传

点击文件名下载附件

跳转到最佳答案楼层

suye1010

1. Sub ExtractData()
   
2. Dim arr, d, Sht, i As Integer, j As Integer
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. For Each Sht In ThisWorkbook.Sheets
   
5.     arr = Sht.Range("G1:CX" & Sht.Range("G65536").End(xlUp).Row)
   
6.         For i = 14 To UBound(arr) - 3 Step 17
   
7.             For j = 1 To UBound(arr, 2)
   
8.                 If CStr(arr(i, j)) = CStr(arr(i + 1, j)) And CStr(arr(i, j)) = CStr(arr(i + 2, j)) Then
   
9.                     d("表" & Sht.Name & "-" & Sht.Cells(i + 3, j + 6).Address(0, 0)) = "表" & Sht.Name & "-" & Sht.Cells(i + 3, j + 6).Address(0, 0)
   
10.                 End If
    
11.             Next j
    
12.         Next i
    
13.     Erase arr
    
14. Next
    
15. ThisWorkbook.Sheets("1").Cells(1, 1).Resize(d.Count, 1) = Application.Transpose(d.keys)
    
16. End Sub

复制代码

条件提取.rar (27.64 KB, 下载次数: 2)

2013-7-4 13:51 上传

点击文件名下载附件