帮助解决自动抓取其他表格数据问题

haha_xion

希望通过VBA实现，在汇总表里自动抓取数据表（多个）中固定区域的数据，附件已上传，望能帮助，谢谢

corvine99

如你所愿，请见附件。。。

haha_xion

有密码！

mineshine

在总表SHEET1加入一個CommandButton:

Private Sub CommandButton1_Click()
Dim n, i, EOFcol, EOFcolS As Integer
Dim File, GetFile As String
Application.ScreenUpdating = False          'Disable the screen updating
Application.DisplayAlerts = False           'Disable the Alerts Information

With Application.FileSearch                 '查找文件
    .NewSearch                              '建立新查找
    .LookIn = ThisWorkbook.Path             '查找的路径
'    .SearchSubFolders = True               '是否查找子目彔
    .Filename = "*.xls"                     '查找的档名*.xls
'    .MatchAllWordForms = True
    .FileType = msoFileTypeAllFiles
    If .Execute() > 0 Then                  '是否查找到文件
        A = .FoundFiles.Count               '查找到文件的个数
        n = 2                               '汇总.xls的工作表数=2
        For i = 1 To .FoundFiles.Count
            GetFile = .FoundFiles(i)        '查找文件完整路径
            File = Right(GetFile, Len(GetFile) - Len(ThisWorkbook.Path) - 1)   '查找文件名称
            If File <> "汇总.xls" Then      '如果找到的文件不是"汇总.xls"就執行下面程序
                Workbooks.Open (GetFile)
                Workbooks(File).ActiveSheet.Range("A2:E" & Workbooks(File).ActiveSheet.[A65536].End(xlUp).Row).Copy     '把开启文有资料的RANGE复制
                Workbooks("汇总.xls").Worksheets(1).Paste Destination:= _
                    Workbooks("汇总.xls").Worksheets(1).Cells(Workbooks("汇总.xls").Worksheets(1).[A65536].End(xlUp).Row + 1, 1)   '將复制的资料贴到("汇总.xls")当前工作表的第一栏列数+1
                ActiveWorkbook.Close
            End If
        Next i
    End If
End With
Workbooks("汇总.xls").Save
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

corvine99

哦，忘记还有密码了。不好意思。

Private Sub Roll_Up_Click()

Dim numFiles As Integer
Dim numRollup As Integer
Dim ctrlCursorRow As Long
Dim ctrlCursorCol As Long
Dim fileList(9999) As String
Dim filePath As String
Dim startCell As String
Dim rangeSelect As String
Dim sheetSelect As String
Dim emptyRow As Long

'change file path to designated folder
filePath = Workbooks("Roll_up.v3.xls").Sheets("Guide").Range("C8").Value
ChDir (filePath)


'get all file names in the folder
Do
    If numFiles = 0 Then
    fileList(numFiles) = Dir("")
    ActiveWorkbook.Sheets("FileDir").Select
    ActiveSheet.Cells(numFiles + 5, "B").Value = fileList(numFiles)
    numFiles = numFiles + 1
    Else
    fileList(numFiles) = Dir
    Workbooks("Roll_up.v3.xls").Worksheets("FileDir").Cells(numFiles + 5, "B").Value = fileList(numFiles)
    numFiles = numFiles + 1
    End If
Loop Until ActiveSheet.Cells(numFiles + 4, "B").Value = ""

'initialize variables
numRollup = numFiles - 2
numFiles = 0
startCell = Workbooks("Roll_up.v3.xls").Sheets("Guide").Range("C10").Value
ctrlCursorRow = Workbooks("Roll_up.v3.xls").Sheets("Rollup").Range(startCell).Row
ctrlCursorCol = Workbooks("Roll_up.v3.xls").Sheets("Rollup").Range(startCell).Column
sheetSelect = Workbooks("Roll_up.v3.xls").Sheets("Guide").Range("C14").Value
rangeSelect = Workbooks("Roll_up.v3.xls").Sheets("Guide").Range("C12").Value

'open each spreadsheet, copy range and paste in current file
For numFiles = 0 To numRollup Step 1

Workbooks.Open (fileList(numFiles))
Workbooks(fileList(numFiles)).Worksheets(sheetSelect).Range(rangeSelect).Copy
Workbooks("Roll_up.v3.xls").Activate
Worksheets("Rollup").Select
ActiveSheet.Cells(ctrlCursorRow, ctrlCursorCol).Select
ActiveSheet.Paste
Call rangeCleanEmptyRows(emptyRow)
ctrlCursorRow = ctrlCursorRow + Workbooks(fileList(numFiles)).Worksheets(sheetSelect).Range(rangeSelect).Rows.Count - emptyRow
Workbooks(fileList(numFiles)).Close

Next

End Sub

Private Sub rangeCleanEmptyRows(ByRef emptyRow As Long)
Dim rangeValue(1 To 9999) As Variant
Dim rangeValueA(1 To 9999) As Variant
Dim T As Variant
Dim rangeRows As Long
Dim rangeCols As Long
Dim S As Variant
Dim Counter As Long
Dim rangeAddr As String
Dim lastRow As Long
Dim lastCol As Long

'Define range and determine last row of range
Workbooks("Roll_up.v3.xls").Sheets("Rollup").Select
rangeAddr = ActiveWindow.RangeSelection.Address(ReferenceStyle:=xlA1)
lastRow = ActiveSheet.Range(rangeAddr).Rows.Count

'Mark the row to last row of range
For lastCol = 1 To (Range(rangeAddr).Columns.Count)
ActiveSheet.Range(rangeAddr).Cells(lastRow + 1, lastCol).Value = "##END_OF_ROLLUP##"
Next


'Count all empty rows and remove any empty rows within range

emptyRow = 0

For rangeRows = 1 To (Range(rangeAddr).Rows.Count)

For rangeCols = 1 To (Range(rangeAddr).Columns.Count)

rangeValue(rangeCols) = IsEmpty(ActiveSheet.Range(rangeAddr).Cells(rangeRows, rangeCols))
rangeValueA(rangeCols) = ActiveSheet.Range(rangeAddr).Cells(rangeRows, rangeCols)

Next rangeCols

Counter = 0

For Each S In rangeValue()
    If S = True Then
    Counter = Counter + 1
    End If
Next S

For Each T In rangeValueA()
    If T = "##END_OF_ROLLUP##" Then
    Exit Sub
    End If
Next T

If Counter = Range(rangeAddr).Columns.Count Then

emptyRow = emptyRow + 1

ActiveSheet.Range(rangeAddr).Rows(rangeRows).Delete

rangeRows = rangeRows - 1


End If

Next rangeRows


End Sub

haha_xion

可否加段代码，就是将抓取过的表改名，例：将数据表1.xls抓完后改为od_数据表1.xls

corvine99

workbooks(filelist(numfiles)).sheets(1).name="od_数据表1"

haha_xion

谢谢各位帮助

haha_xion

谢谢！再次请教您，如果加句将读取完的表格的后缀名(.xls)去除该怎么写，谢谢！

corvine99

不太明白，可以在改变名称时候不写".xls"....