【新人求助】想做个从每个表格做提取指定单元格内容汇总至一行的vba，调试时报错

cymophane

各位大佬。我想做一个遍历每个表从指定单元格提取内容至一行的小程序，最后运行到    Range("A2").Resize(i, 4).Value = Application.Transpose(arr)
老是提示无效的过程调用或参数 ，不知道如何调整，请大佬帮忙看一下谢谢！


附：

1. Sub 提取信息()
   
2.     Range("A1").CurrentRegion.Offset(1, 0).ClearContents
   
3.     Cells.Borders.LineStyle = xlNone
   
4.     Application.ScreenUpdating = False
   
5.     Dim wb As Excel.Workbook
   
6.     Dim cPath$, cFile$, i%, arr()
   
7.     cPath = ThisWorkbook.Path & "\测试表"
   
8.     Set wordapp = CreateObject("word.Application")
   
9.     Do While cFile <> ""
   
10.         Set wb = Workbook.Open(cPath & cFile)
    
11.         i = i + 1
    
12.         ReDim Preserve arr(1 To 4, 1 To i)
    
13.         With wb
    
14.             arr(1, i) = Worksheets(3).Range("C6").Value
    
15.             arr(2, i) = Worksheets(3).Range("E6").Value
    
16.             arr(3, i) = Worksheets(3).Range("C7").Value
    
17.             arr(4, i) = Worksheets(3).Range("C8").Value
    
18.         End With
    
19.         wb.Close
    
20.         cFile = Dir
    
21.     Loop
    
22.     Set wb = Nothing
    
23.     Range("A2").Resize(i, 4).Value = Application.Transpose(arr)
    
24.     Range("A1:D" & i + 1).Borders.LineStyle = xlContinuous
    
25.     Application.ScreenUpdating = True
    
26. End Sub
    
27. 
    

复制代码

zhangcheng6688

提供附件的话，可以给你看看

LMY123

Sub Macro1()
    Dim Fso As Object, File As Object
    Dim cnn As Object, rs As Object, SQL$
    Dim arr(), m&
    Application.ScreenUpdating = False
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set cnn = CreateObject("adodb.connection")
    ReDim arr(1 To Fso.GetFolder(ThisWorkbook.Path & "\汇总示意表").Files.Count, 1 To 2)
    For Each File In Fso.GetFolder(ThisWorkbook.Path & "\汇总示意表").Files
        If File.Name Like "*.xlsx" Then
            m = m + 1
            If m = 1 Then cnn.Open "Provider=Microsoft.ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & File
            SQL = "select f1 from [Excel 12.0;hdr=no;Database=" & File & ";].[Sheet1$c2:c2]"
            Set rs = cnn.Execute(SQL)
            arr(m, 1) = rs.Fields(0)
            SQL = "select sum(f1) from [Excel 12.0;hdr=no;Database=" & File & ";].[Sheet1$F4:H] where f3 is not null"
            Set rs = cnn.Execute(SQL)
            arr(m, 2) = rs.Fields(0)
        End If
    Next
    ActiveSheet.UsedRange.Offset(1).ClearContents
    [a2].Resize(m, 2) = arr
    Set File = Nothing
    Set Fso = Nothing
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
    Application.ScreenUpdating = True
End Sub

LMY123

Sub DFDF()
  Application.ScreenUpdating = False
  p = ThisWorkbook.Path & "\"
  D = Split("M2 D10 F10 H10 J10 M10 O10 Q10 S10")
  n = 4
  For Each File In CreateObject("Scripting.FilesyStemObject").GetFolder(ThisWorkbook.Path & "/").Files
    If File.Name <> ThisWorkbook.Name And Left(File.Name, 1) <> "~" And File.Name Like "*.xls*" Then
      For K = 0 To UBound(D)
        T$ = "='" & p & "[" & File.Name & "]" & "成绩学分登记表'!" & Range(D(K)).Address(, , xlR1C1)
        Range(Chr(K + 65) & n) = Vi(T, Chr(K + 65) & n)
      Next
    End If
    n = n + 1
  Next
  Application.ScreenUpdating = True
End Sub
Function Vi(T$, G$)
  Range(G) = T
  Vi = Range(G).Value
End Function
Sub 提取英语数据()
Dim wb As Workbook
Dim arr(1 To 5000, 1 To 11)
Dim mypath$, myname$
Application.DisplayAlerts = False
Application.ScreenUpdating = False
mypath = ThisWorkbook.Path & "/"
myname = Dir(mypath & "*.xl*")
Do While myname <> ""
   If myname <> ThisWorkbook.Name Then
      Set wb = GetObject(mypath & myname)
      With wb
        With .Worksheets("成绩学分登记表")
            n = n + 1
            arr(n, 1) = .[m2]
            arr(n, 2) = .[c2]
            arr(n, 3) = .[i2]
            arr(n, 4) = .[d10]
            arr(n, 5) = .[f10]
            arr(n, 6) = .[h10]
            arr(n, 7) = .[j10]
            arr(n, 8) = .[m10]
            arr(n, 9) = .[o10]
            arr(n, 10) = .[q10]
            arr(n, 11) = .[s10]
        End With
        wb.Close False
      End With
    End If
myname = Dir()
Loop
With ThisWorkbook.Worksheets("汇总")
  .[a4].Resize(UBound(arr), 11) = arr
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "提取完成，请核查！"
End Sub

oscarwmf

Range("A2").Resize(i, 4).Value = Application.Transpose(arr)
改成
Range("A2").Resize(i, 4) = Application.Transpose(arr)

cymophane

oscarwmf 发表于 2018-9-30 12:18
Range("A2").Resize(i, 4).Value = Application.Transpose(arr)
改成
Range("A2").Resize(i, 4) = Applic ...

这个还是一样的提示啊

cymophane

zhangcheng6688 发表于 2018-9-30 11:27
提供附件的话，可以给你看看

这是测试附件，谢谢！

不知道为什么

cymophane 发表于 2018-9-30 13:21
这是测试附件，谢谢！

不说其它，就是你最后 用 transpose  ，arr是二维数组，函数是针对一维的

cymophane

LMY123 发表于 2018-9-30 12:02
Sub Macro1()
    Dim Fso As Object, File As Object
    Dim cnn As Object, rs As Object, SQL$

大神使用了SQL吗，我读不太懂语句啊，不知道怎么根据实际表格进行调整

zhangcheng6688

cymophane 发表于 2018-9-30 13:21
这是测试附件，谢谢！

Sub test()
Range("A1").CurrentRegion.Offset(1, 0).ClearContents
    Cells.Borders.LineStyle = xlNone
    Application.ScreenUpdating = False
    Dim wb As Excel.Workbook
    Dim cPath$, cFile$, i%, arr()
    cPath = ThisWorkbook.Path & "\"
    'Set wordapp = CreateObject("word.Application")
    cFile = Dir(cPath & "*.xlsx")
    Do While cFile <> ""
        Set wb = Workbooks.Open(cPath & cFile)
        i = i + 1
        ReDim Preserve arr(1 To 4, 1 To i)
        With wb
            arr(1, i) = Sheets("sheet1").Range("C6").Value
            arr(2, i) = Sheets("sheet1").Range("e6").Value
            arr(3, i) = Sheets("sheet1").Range("C7").Value
            arr(4, i) = Sheets("sheet1").Range("C8").Value
        End With
        wb.Close
        cFile = Dir
    Loop
    Set wb = Nothing
    Range("A2").Resize(i, 4) = Application.Transpose(arr)
    Range("A1:D" & i + 1).Borders.LineStyle = xlContinuous
    Application.ScreenUpdating = True
End Sub
经测试有效