[已解决]指定条件提取数据的问题－－有赏

晓敏

附件 指定条件提取数据.rar (730.48 KB, 下载次数: 21)

2016-3-6 18:43 上传

点击文件名下载附件
谢谢各位老师！

最佳答案

月排行榜 / 总排行榜

grf1973

2016-3-8 10:08

只找上排的33.。。。

1. Sub 读取()
   
2.     Dim sh As Worksheet, wb As Workbook
   
3.     Application.ScreenUpdating = False
   
4.     x = [k1]
   
5.     Set fso = CreateObject("scripting.filesystemobject")
   
6.     Set ff = fso.getfolder(ThisWorkbook.Path)
   
7.     For Each fff In ff.subfolders       '对于每一个子文件夹
   
8.        Worksheets.Add after:=Sheets(Sheets.Count)       '新建工作表
   
9.        Set sh = ActiveSheet
   
10.        sh.Name = fff.Name       '新表名=子文件夹名
    
11.        ReDim brr(1 To 10000, 1 To 30)
    
12.        For Each f In fff.Files          '对于子文件夹中的每一个文件
    
13.           Set wb = Workbooks.Open(f)
    
14.           k = Val(f.Name)       '文件名对应的数值
    
15.           If r > 0 Then r = r + 1
    
16.           With wb.Sheets(k)           '文件名c，取对应工作表c
    
17.             arr = .UsedRange
    
18.             cc = UBound(arr, 2)
    
19.             If cc > cmax Then cmax = cc
    
20.             For i = 1 To UBound(arr) - 1
    
21.                 If arr(i, cc) = x And arr(i + 1, 1) <> "" Then   '找最后一个数为指定数的行（只针对上行）
    
22.                     r = r + 1
    
23.                     For c = 1 To cc      '符合条件的读入Brr
    
24.                         brr(r, c) = arr(i, c)
    
25.                         brr(r + 1, c) = arr(i + 1, c)
    
26.                     Next
    
27.                     r = r + 2
    
28.                 End If
    
29.             Next
    
30.           End With
    
31.           wb.Close False
    
32.        Next
    
33.        If r > 0 Then sh.[a1].Resize(r, cmax) = brr
    
34.        r = 0: cmax = 0
    
35.     Next
    
36.     Application.ScreenUpdating = True
    
37. End Sub

复制代码

跳转到最佳答案楼层

QCW911

加qq57726980

grf1973

1. Sub 读取()
   
2.     Dim sh As Worksheet, wb As Workbook
   
3.     Application.ScreenUpdating = False
   
4.     x = [k1]
   
5.     Set fso = CreateObject("scripting.filesystemobject")
   
6.     Set ff = fso.getfolder(ThisWorkbook.Path)
   
7.     For Each fff In ff.subfolders       '对于每一个子文件夹
   
8.        Worksheets.Add after:=Sheets(Sheets.Count)       '新建工作表
   
9.        Set sh = ActiveSheet
   
10.        sh.Name = fff.Name       '新表名=子文件夹名
    
11.        ReDim brr(1 To 10000, 1 To 30)
    
12.        For Each f In fff.Files          '对于子文件夹中的每一个文件
    
13.           Set wb = Workbooks.Open(f)
    
14.           k = Val(f.Name)       '文件名对应的数值
    
15.           If r > 0 Then r = r + 1
    
16.           With wb.Sheets(k)           '文件名c，取对应工作表c
    
17.             arr = .UsedRange
    
18.             cc = UBound(arr, 2)
    
19.             If cc > cmax Then cmax = cc
    
20.             For i = 1 To UBound(arr)
    
21.                 If arr(i, cc) = x Then   '找最后一个数为指定数的行
    
22.                     If i = 1 Then     '判断该行是上行还是下行，j为上行
    
23.                         j = 1
    
24.                     Else
    
25.                         If arr(i - 1, 1) <> "" Then j = i - 1 Else j = i
    
26.                     End If
    
27.                     
    
28.                     r = r + 1
    
29.                     For c = 1 To cc      '符合条件的读入Brr
    
30.                         brr(r, c) = arr(j, c)
    
31.                         brr(r + 1, c) = arr(j + 1, c)
    
32.                     Next
    
33.                     r = r + 2
    
34.                 End If
    
35.             Next
    
36.           End With
    
37.           wb.Close False
    
38.        Next
    
39.        If r > 0 Then sh.[a1].Resize(r, cmax) = brr
    
40.        r = 0: cmax = 0
    
41.     Next
    
42.     Application.ScreenUpdating = True
    
43. End Sub

复制代码

晓敏

grf1973 发表于 2016-3-7 15:41

老师您好，谢谢了．试了一下，发现一点小问题．

一组数据，由两行组成．要判断的是该组数据的　　第一行的最后一个数．

您的代码多判断了一个，把一组数据中，第二行的最后一个也判了出来．如下图：




前面两组的３３在该组数据的第二行．

Marlin_

grf1973 发表于 2016-3-7 15:41

您好，有些问题想咨询您能方便给个联系方式么 ？谢谢

grf1973

只找上排的33.。。。

1. Sub 读取()
   
2.     Dim sh As Worksheet, wb As Workbook
   
3.     Application.ScreenUpdating = False
   
4.     x = [k1]
   
5.     Set fso = CreateObject("scripting.filesystemobject")
   
6.     Set ff = fso.getfolder(ThisWorkbook.Path)
   
7.     For Each fff In ff.subfolders       '对于每一个子文件夹
   
8.        Worksheets.Add after:=Sheets(Sheets.Count)       '新建工作表
   
9.        Set sh = ActiveSheet
   
10.        sh.Name = fff.Name       '新表名=子文件夹名
    
11.        ReDim brr(1 To 10000, 1 To 30)
    
12.        For Each f In fff.Files          '对于子文件夹中的每一个文件
    
13.           Set wb = Workbooks.Open(f)
    
14.           k = Val(f.Name)       '文件名对应的数值
    
15.           If r > 0 Then r = r + 1
    
16.           With wb.Sheets(k)           '文件名c，取对应工作表c
    
17.             arr = .UsedRange
    
18.             cc = UBound(arr, 2)
    
19.             If cc > cmax Then cmax = cc
    
20.             For i = 1 To UBound(arr) - 1
    
21.                 If arr(i, cc) = x And arr(i + 1, 1) <> "" Then   '找最后一个数为指定数的行（只针对上行）
    
22.                     r = r + 1
    
23.                     For c = 1 To cc      '符合条件的读入Brr
    
24.                         brr(r, c) = arr(i, c)
    
25.                         brr(r + 1, c) = arr(i + 1, c)
    
26.                     Next
    
27.                     r = r + 2
    
28.                 End If
    
29.             Next
    
30.           End With
    
31.           wb.Close False
    
32.        Next
    
33.        If r > 0 Then sh.[a1].Resize(r, cmax) = brr
    
34.        r = 0: cmax = 0
    
35.     Next
    
36.     Application.ScreenUpdating = True
    
37. End Sub

复制代码