將excel數據從已關閉的excel複製到另一個excel表

Question

下面的代碼正在工作，但不是將excel表格中的數據複製到Excel表格中，而是正在打開一個帶有所需輸出的新Excel表格。

我已經指定以下宏按鈕，每5分鐘，如果我上點擊鏈接應該刷新細節

Sub extractDataFromClosedFile() 

On Error GoTo ErrHandler 
Application.ScreenUpdating = False 

Dim src As Workbook 
Set src = Workbooks.Open("C:\Users\test.xls", True, True) 

Dim iTotalRows As Integer 
iTotalRows = src.Worksheets("Sheet1").Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row).Rows.Count 

Dim iCnt As Integer 

For iCnt = 1 To iTotalRows 
Worksheets("Sheet6").Range("A3" & iCnt).Formula = src.Worksheets("Sheet1").Range("b" & iCnt).Formula 
Next iCnt 

src.Close False 
Set src = Nothing 

ErrHandler: 
Application.EnableEvents = True 
Application.ScreenUpdating = True 
Debug.Print Err.Description 

End Sub 

Answer 1

，您可以嘗試這種方式。

Sub GetData_Example1() 
' It will copy the Header row also (the last two arguments are True) 
' Change the last argument to False if you not want to copy the header row 
    GetData ThisWorkbook.Path & "\test.xls", "Sheet1", _ 
      "A1:C5", Sheets("Sheet1").Range("A1"), True, True 
End Sub 
Option Explicit 


Public Sub GetData(SourceFile As Variant, SourceSheet As String, _ 
        SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean) 
' 30-Dec-2007, working in Excel 2000-2007 
    Dim rsCon As Object 
    Dim rsData As Object 
    Dim szConnect As String 
    Dim szSQL As String 
    Dim lCount As Long 

    ' Create the connection string. 
    If Header = False Then 
     If Val(Application.Version) < 12 Then 
      szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _ 
         "Data Source=" & SourceFile & ";" & _ 
         "Extended Properties=""Excel 8.0;HDR=No"";" 
     Else 
      szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _ 
         "Data Source=" & SourceFile & ";" & _ 
         "Extended Properties=""Excel 12.0;HDR=No"";" 
     End If 
    Else 
     If Val(Application.Version) < 12 Then 
      szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _ 
         "Data Source=" & SourceFile & ";" & _ 
         "Extended Properties=""Excel 8.0;HDR=Yes"";" 
     Else 
      szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _ 
         "Data Source=" & SourceFile & ";" & _ 
         "Extended Properties=""Excel 12.0;HDR=Yes"";" 
     End If 
    End If 

    If SourceSheet = "" Then 
     ' workbook level name 
     szSQL = "SELECT * FROM " & SourceRange$ & ";" 
    Else 
     ' worksheet level name or range 
     szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];" 
    End If 

    On Error GoTo SomethingWrong 

    Set rsCon = CreateObject("ADODB.Connection") 
    Set rsData = CreateObject("ADODB.Recordset") 

    rsCon.Open szConnect 
    rsData.Open szSQL, rsCon, 0, 1, 1 

    ' Check to make sure we received data and copy the data 
    If Not rsData.EOF Then 

     If Header = False Then 
      TargetRange.Cells(1, 1).CopyFromRecordset rsData 
     Else 
      'Add the header cell in each column if the last argument is True 
      If UseHeaderRow Then 
       For lCount = 0 To rsData.Fields.Count - 1 
        TargetRange.Cells(1, 1 + lCount).Value = _ 
        rsData.Fields(lCount).Name 
       Next lCount 
       TargetRange.Cells(2, 1).CopyFromRecordset rsData 
      Else 
       TargetRange.Cells(1, 1).CopyFromRecordset rsData 
      End If 
     End If 

    Else 
     MsgBox "No records returned from : " & SourceFile, vbCritical 
    End If 

    ' Clean up our Recordset object. 
    rsData.Close 
    Set rsData = Nothing 
    rsCon.Close 
    Set rsCon = Nothing 
    Exit Sub 

SomethingWrong: 
    MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _ 
      vbExclamation, "Error" 
    On Error GoTo 0 

End Sub 

Function LastRow(sh As Worksheet) 
    On Error Resume Next 
    LastRow = sh.Cells.Find(What:="*", _ 
          After:=sh.Range("A1"), _ 
          Lookat:=xlPart, _ 
          LookIn:=xlFormulas, _ 
          SearchOrder:=xlByRows, _ 
          SearchDirection:=xlPrevious, _ 
          MatchCase:=False).Row 
    On Error GoTo 0 
End Function 


Function Array_Sort(ArrayList As Variant) As Variant 
    Dim aCnt As Integer, bCnt As Integer 
    Dim tempStr As String 

    For aCnt = LBound(ArrayList) To UBound(ArrayList) - 1 
     For bCnt = aCnt + 1 To UBound(ArrayList) 
      If ArrayList(aCnt) > ArrayList(bCnt) Then 
       tempStr = ArrayList(bCnt) 
       ArrayList(bCnt) = ArrayList(aCnt) 
       ArrayList(aCnt) = tempStr 
      End If 
     Next bCnt 
    Next aCnt 
    Array_Sort = ArrayList 
End Function 

從這裏：

http://www.rondebruin.nl/win/s3/win024.htm