VBA从别的Excel复制数据并生成新文件

Option Explicit

Sub Selected_File(ByVal num As String)
　　Application.DisplayAlerts = False
　　Dim Filename As String
　　Filename = Application.GetOpenFilename(fileFilter:="Excel文件(*.xls*),*.xls*", Title:="选择Excel文件", MultiSelect:=False)
　　If Filename <> "" And Filename <> "False" Then
　　　　If num = 1 Then
　　　　　　Cells(4, 4) = Filename
　　　　　　FirstClickSetBtnEnabled
　　　　ElseIf num = 2 Then
　　　　　　Cells(6, 4) = Filename
　　　　ElseIf num = 3 Then
　　　　　　Cells(8, 4) = Filename
　　　　ElseIf num = 4 Then
　　　　　　Cells(11, 4) = Filename
　　　　　　ForthClickSetBtnEnabled
　　　　ElseIf num = 5 Then
　　　　　　Cells(14, 4) = Filename
　　　　ElseIf num = 6 Then
　　　　　　Cells(16, 4) = Filename
　　　　ElseIf num = 7 Then
　　　　　　Cells(18, 4) = Filename
　　　　ElseIf num = 8 Then
　　　　　　Cells(20, 4) = Filename
　　　　ElseIf num = 9 Then
　　　　　　Cells(23, 4) = Filename
　　　　　　NinthClickSetBtnEnabled
　　　　ElseIf num = 10 Then
　　　　　　Cells(26, 4) = Filename
　　　　ElseIf num = 11 Then
　　　　　　Cells(28, 4) = Filename
　　　　ElseIf num = 12 Then
　　　　　　Cells(30, 4) = Filename
　　　　ElseIf num = 13 Then
　　　　　　Cells(32, 4) = Filename
　　　　End If
　　Application.DisplayAlerts = True
　　End If
End Sub

Sub CopyFileInfo(ByVal num As String)
　　Dim wb As Workbook
　　Dim i, uCount, oCount As Integer
　　Dim filePaths(4) As String

　　If num = 1 Then
　　　　If Cells(4, 4) = "" And Cells(6, 4) = "" And Cells(8, 4) = "" Then
　　　　　　MsgBox ("没有选择文件。")
　　　　　　Exit Sub
　　　　End If
　　End If

　　If num = 2 Then
　　　　If Cells(14, 4) = Cells(16, 4) Then
　　　　　　MsgBox ("选择了同名文件。")
　　　　　　Exit Sub
　　　　End If
　　End If

　　If num = 3 Then
　　　　If Cells(26, 4) = "" And Cells(28, 4) = "" And Cells(30, 4) = "" And Cells(32, 4) = "" Then
　　　　　　MsgBox ("文件没有选择。")
　　　　　　Exit Sub
　　　　Else
　　　　　　filePaths(1) = Cells(26, 4)
　　　　　　filePaths(2) = Cells(28, 4)
　　　　　　filePaths(3) = Cells(30, 4)
　　　　　　filePaths(4) = Cells(32, 4)
　　　　End If
　　End If

　　For i = 0 To 4
　　　　'检验对象文件是否存在
　　　　If filePaths(i) <> "" And Dir(filePaths(i)) = "" Then
　　　　　　MsgBox ("选择的文件不存在。文件名：" + filePaths(i))
　　　　　　Exit Sub
　　　　End If
　　　　'检查同名文件是否打开了
　　　　If filePaths(i) <> "" Then
　　　　　　On Error Resume Next
　　　　　　Open filePaths(i) For Binary Access Read Write Lock Read Write As #1
　　　　　　Close #1
　　　　　　If Err.Number <> 0 Then
　　　　　　　　MsgBox ("已经打开了一个同名文件。文件名：" + filePaths(i))
　　　　　　　　Exit Sub
　　　　　　End If
　　　　End If
　　Next

　　'复制文件内容
　　Set wb = GetObject(filePaths(0))
　　wb.Sheets(1).Cells.Copy ThisWorkbook.Sheets(4).Cells
　　wb.Close

　　If filePaths(4) = "" Then
　　　　'复制文件内容
　　　　Set wb = GetObject(filePaths(1))
　　　　wb.Sheets(1).Cells.Copy ThisWorkbook.Sheets(2).Cells
　　　　wb.Close
　　　　'复制文件内容
　　　　Set wb = GetObject(filePaths(2))
　　　　wb.Sheets(1).Cells.Copy ThisWorkbook.Sheets(3).Cells
　　　　wb.Close
　　Else
　　　　'复制文件内容
　　　　Set wb = GetObject(filePaths(1))
　　　　wb.Sheets(1).Cells.Copy ThisWorkbook.Sheets(2).Cells
　　　　wb.Close
　　　　Set wb = GetObject(filePaths(2))
　　　　uCount = wb.Sheets(1).UsedRange.Rows.Count
　　　　oCount = ThisWorkbook.Sheets(2).UsedRange.Rows.Count + 1
　　　　wb.Sheets(1).Range("A2:Z" & uCount).Cells.Copy ThisWorkbook.Sheets(2).Range("A" & oCount).Cells
　　　　wb.Close
　　　　'复制文件内容
　　　　Set wb = GetObject(filePaths(3))
　　　　wb.Sheets(1).Cells.Copy ThisWorkbook.Sheets(3).Cells
　　　　wb.Close
　　　　Set wb = GetObject(filePaths(4))
　　　　uCount = wb.Sheets(1).UsedRange.Rows.Count
　　　　oCount = ThisWorkbook.Sheets(3).UsedRange.Rows.Count + 1
　　　　wb.Sheets(1).Range("A2:Z" & uCount).Cells.Copy ThisWorkbook.Sheets(3).Range("A" & oCount).Cells
　　　　wb.Close
　　End If
　　CreateResultFile
End Sub

Sub CreateResultFile()
　　Dim wb As Workbook
　　Dim ws As Worksheet
　　Dim i, j As Integer
　　Dim filePath As String
　　Dim conn, relSet, fs
　　Dim extenName$, connStr$, sqlStr$
　　filePath = CurDir & "\差异验证结果_" & Year(Date) & Month(Date) & ".xlsx"
　　If Dir(filePath) <> "" Then
　　　　Kill filePath
　　End If
　　Set fs = CreateObject("Scripting.FileSystemObject")
　　extenName = fs.GetExtensionName(ThisWorkbook.FullName)
　　If extenName = "xls" Then
　　　　connStr = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;" & _
　　　　"Data Source=" & ThisWorkbook.FullName
　　ElseIf extenName = "xlsx" Or extenName = "xlsm" Then
　　　　connStr = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;" & _
　　　　"Data Source=" & ThisWorkbook.FullName
　　End If
　　Set fs = Nothing
　　Set conn = CreateObject("ADODB.Connection")
　　Set relSet = CreateObject("ADODB.RecordSet")
　　Set wb = Workbooks.Add
　　sqlStr = "SELECT '定金' AS 定金定率区分, MEISAI_TEIGAKU.订单编号FROM [定金明细$] AS MEISAI_TEIGAKU " & _
　　" Union " & _
　　"SELECT '定率' AS 定金定率区分, MEISAI_TEIRITSU.订单编号 FROM [定率定金明细$] AS MEISAI_TEIRITSU " & _
　　"WHERE " & _
　　"NOT EXISTS (" & _
　　"SELECT * FROM [检测明細$] AS MEISAI_CHECK " & _
　　"WHERE " & _
　　"MEISAI_TEIRITSU.订单编号 = MEISAI_CHECK.ORDER_ID )"

　　conn.Open connStr
　　relSet.Open sqlStr, conn, 1, 3
　　'Set relSet = conn.Execute(sqlStr)
　　wb.Sheets(1).Name = "概要"
　　If relSet.RecordCount > 0 Then
　　　　wb.Sheets(1).Range("A1") = "有件数差异。"
　　Else
　　　　wb.Sheets(1).Range("A1") = "没有件数差异。"
　　End If
　　wb.Sheets(1).Range("A3") = "定金／定率"
　　wb.Sheets(1).Range("B3") = "订单编号"
　　wb.Sheets(1).Range("A4").CopyFromRecordset relSet
　　relSet.Close

　　sqlStr = "SELECT " & _
　　"MEISAI_TEIGAKU.合计" & _
　　", MEISAI_CHECK.ITRACK_INFO " & _
　　", MEISAI_CHECK.REMOTE_ADDR " & _
　　", MEISAI_CHECK.HTTP_USER_AGENT " & _
　　"FROM " & _
　　"[定金明细$] AS MEISAI_TEIGAKU " & _
　　"INNER JOIN [检查用明細$] AS MEISAI_CHECK " & _
　　"ON MEISAI_TEIGAKU.订单编号 = MEISAI_CHECK.ORDER_ID " & _
　　"WHERE " & _
　　"CStr(MEISAI_TEIGAKU.合计) <> MEISAI_CHECK.SALES_AMOUNT"

　　relSet.Open sqlStr, conn, 1, 3

　　i = 0
　　Do While Not relSet.EOF
　　　　i = i + 1
　　　　Set ws = wb.Sheets.Add(After:=Sheets(i))
　　　　ws.Name = relSet.Fields.Item(6).Value
　　　　ws.Range("A1") = "エラー概要"
　　　　ws.Range("B1") = "販売金額に差異があります。（VC明細データ:\" & relSet.Fields.Item(0).Value & "／請求書チェック用明細データ:\" & relSet.Fields.Item(8).Value & "）"
　　　　For j = 0 To relSet.Fields.Count - 1
　　　　　　If j = 1 Or j = 6 Then
　　　　　　　　ws.Range("B" & (j + 2)).NumberFormatLocal = "@"
　　　　　　End If
　　　　　　ws.Range("A" & (j + 2)) = relSet.Fields.Item(j).Name
　　　　　　ws.Range("B" & (j + 2)) = relSet.Fields.Item(j).Value
　　　　Next
　　　　relSet.MoveNext
　　Loop

　　wb.SaveAs filePath
　　wb.Close False
　　Set relSet = Nothing
　　conn.Close
　　Set conn = Nothing

　　MsgBox ("差异验证结束。")
End Sub

Private Sub ExeBtn_Click()
　　If Cells(4, 4) <> "" And Me.FirstBtn.Enabled = True Then
　　　　CopyFileInfo (1)
　　ElseIf Cells(11, 4) <> "" And Me.ForthBtn.Enabled = True Then
　　　　CopyFileInfo (2)
　　ElseIf Cells(23, 4) <> "" And Me.NinthBtn.Enabled = True Then
　　　　CopyFileInfo (3)
　　End If
End Sub

Private Sub FirstBtn_Click()
　　Selected_File (1)
End Sub

Private Sub SecondBtn_Click()
　　Selected_File (2)
End Sub

Private Sub ThirdBtn_Click()
　　Selected_File (3)
End Sub

 

 

Sub FirstClickSetBtnEnabled()
　　Me.FirstBtn.Enabled = True
　　Me.SecondBtn.Enabled = True
　　Me.ThirdBtn.Enabled = True
End Sub

Sub ForthClickSetBtnEnabled()
　　Me.FirstBtn.Enabled = False
　　Me.SecondBtn.Enabled = False
　　Me.ThirdBtn.Enabled = False
End Sub

Sub NinthClickSetBtnEnabled()
　　Me.FirstBtn.Enabled = False
　　Me.SecondBtn.Enabled = True
　　Me.ThirdBtn.Enabled = True
End Sub

Sub OpenAutoExecute()
　　Me.FirstBtn.Enabled = True
　　Me.SecondBtn.Enabled = True
　　Me.ThirdBtn.Enabled = True
　　Me.Cells(4, 4) = ""
　　Me.Cells(6, 4) = ""
　　Me.Cells(8, 4) = ""
End Sub

--------------------------------------------------------------------------------------------

Excel文件刚打开时执行的操作

Private Sub Workbook_Open()
　　Sheet1.Activate
　　Sheet1.OpenAutoExecute
　　Sheet2.Cells.Clear
　　Sheet3.Cells.Clear
　　Sheet4.Cells.Clear
End Sub