跨文件按条件提取所有工作表中对应数字到另一张excel表

happyjossie

求各位大神帮忙～我需要把几个工作表中特定文字对应的数字汇总到【小程序】这张表里面。【小程序】表里面第一行那些就是那些特定文字，然后我需要提取其他几个表中文字对应的L列的内容。麻烦的地方就在于那几个表里面顺序是乱的，所以我没办法按单元格来提取，而用文字提取的话我不会，所以想求助一下大神们～～

happyjossie

朱荣兴 发表于 2018-8-22 23:48
字典匹配呀

您好，我不会用字典匹配，但我尝试用别的做了一下，还是不行，能帮我看一下代码有什么问题吗？
Dim d(0 To 367) As String
Dim i As Integer, n As Integer


Sub data2()
n = Range("A1000000").End(xlUp).Row
For i = 2 To n Step 1

    d(i) = Range("A" & i) '读取相应日期

    Set fname = GetObject(ThisWorkbook.Path & "\" & d(i) & ".xls") '打开对应日期名文件
'复制粘贴单元格
     Dim m As Integer

For m = 2 To n Step 1

If fname.Sheets("sheet1").Range("D" & m).Value Like "银行存款" Then
fname.Sheets("sheet1").Range("L" & m).Copy ActiveSheet.Range("B" & i)
Else
Exit For
End If
Next m

For m = 2 To n
If fname.Sheets("sheet1").Range("D" & m).Value Like "结算备付金" Then
fname.Sheets("sheet1").Range("L" & m).Copy ActiveSheet.Range("C" & i)
Else
Exit For
End If
Next m

For m = 2 To n
If fname.Sheets("sheet1").Range("D" & m).Value Like "上交所结算保付金" Then
fname.Sheets("sheet1").Range("L" & m).Copy ActiveSheet.Range("D" & i)
Else
Exit For
End If
Next m

For m = 2 To n
If fname.Sheets("sheet1").Range("D" & m).Value Like "上海结算保证金" Then
fname.Sheets("sheet1").Range("L" & m).Copy ActiveSheet.Range("E" & i)
Else
Exit For
End If
Next m

For m = 2 To n
If fname.Sheets("sheet1").Range("D" & m).Value Like "深交所结算保证金" Then
fname.Sheets("sheet1").Range("L" & m).Copy ActiveSheet.Range("F" & i)
Else
Exit For
End If
Next m


For m = 2 To n
If fname.Sheets("sheet1").Range("D" & m).Value Like "东证期货存出保证金" Then
fname.Sheets("sheet1").Range("L" & m).Copy ActiveSheet.Range("G" & i)
Else
Exit For
End If
Next m

For m = 2 To n
If fname.Sheets("sheet1").Range("D" & m).Value Like "东方添益债券" Then
fname.Sheets("sheet1").Range("L" & m).Copy ActiveSheet.Range("H" & i)
Else
Exit For
End If
Next m

For m = 2 To n
If fname.Sheets("sheet1").Range("D" & m).Value Like "海富对冲" Then
fname.Sheets("sheet1").Range("L" & m).Copy ActiveSheet.Range("I" & i)
Else
Exit For
End If
Next m

For m = 2 To n
If fname.Sheets("sheet1").Range("D" & m).Value Like "股票投资" Then
fname.Sheets("sheet1").Range("L" & m).Copy ActiveSheet.Range("K" & i)
Else
Exit For
End If
Next m

For m = 2 To n
If fname.Sheets("sheet1").Range("D" & m).Value Like "黄金ETF" Then
fname.Sheets("sheet1").Range("L" & m).Copy ActiveSheet.Range("L" & i)
Else
Exit For
End If
Next m

For m = 2 To n
If fname.Sheets("sheet1").Range("D" & m).Value Like "泓德远见混合" Then
fname.Sheets("sheet1").Range("L" & m).Copy ActiveSheet.Range("M" & i)
Else
Exit For
End If
Next m

For m = 2 To n
If fname.Sheets("sheet1").Range("D" & m).Value Like "国泰中小盘混合" Then
fname.Sheets("sheet1").Range("L" & m).Copy ActiveSheet.Range("N" & i)
Else
Exit For
End If
Next m

For m = 2 To n
If fname.Sheets("sheet1").Range("D" & m).Value Like "国泰价值" Then
fname.Sheets("sheet1").Range("L" & m).Copy ActiveSheet.Range("O" & i)
Else
Exit For
End If
Next m

For m = 2 To n
If fname.Sheets("sheet1").Range("D" & m).Value Like "交银核心" Then
fname.Sheets("sheet1").Range("L" & m).Copy ActiveSheet.Range("P" & i)
Else
Exit For
End If
Next m

For m = 2 To n
If fname.Sheets("sheet1").Range("D" & m).Value Like "华商盛世混合" Then
fname.Sheets("sheet1").Range("L" & m).Copy ActiveSheet.Range("Q" & i)
Else
Exit For
End If
Next m
        
        fname.Close SaveChanges:=False '关闭文件并取消保存
   
    Set fname = Nothing
Next i

End Sub

liulang0808

1. Sub data2()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Set fso = CreateObject("scripting.filesystemobject")
   
4.     Set sh = ActiveSheet
   
5.     Application.ScreenUpdating = False
   
6.     Application.DisplayAlerts = False
   
7.     a = 2
   
8.     ActiveSheet.UsedRange.Offset(1).ClearContents
   
9.     For Each f In fso.getfolder(ThisWorkbook.Path).Files
   
10.         If InStr(f.Name, "小程序") = 0 Then
    
11.             d.RemoveAll
    
12.             Cells(a, 1) = Split(f.Name, ".xls")(0)
    
13.             brr = ActiveSheet.UsedRange
    
14.             With Workbooks.Open(f)
    
15.                 arr = .Sheets(1).UsedRange
    
16.                 For j = 2 To UBound(arr)
    
17.                     d(arr(j, 4)) = arr(j, 12) + d(arr(j, 4))
    
18.                 Next j
    
19.                 .Close False
    
20.             End With
    
21.             For j = 2 To UBound(brr, 2)
    
22.                 Cells(a, j) = d(brr(1, j))
    
23.             Next j
    
24.             a = a + 1
    
25.         End If
    
26.     Next f
    
27.     Application.DisplayAlerts = True
    
28.     Application.ScreenUpdating = True
    
29. End Sub
    

复制代码

liulang0808

不知道理解的对不对，供参考。。。。。。

liulang0808

happyjossie 发表于 2018-8-23 16:33
非常感谢大神！！就是想实现这样的效果！不过我用真实数据运行的时候出现了点问题，前几行第一列出现了重 ...

还是整个完整的模拟文件看看吧