Oscar Sun

                  Sub 資料比對_將另一個活頁簿資料插入本地活頁簿() '2016/3/31
Dim wb As Workbook, wbNew As Workbook, st As Worksheet, stNew As Worksheet, x As String
Dim clm As Integer, clmOrn As Integer, c As Object, cNew As Object
Dim i As Integer, j As Integer, clmNewText As String
Set wb = Workbooks(1) '先開要插入的活頁簿(來源excel檔)'來源與目的二活頁簿均須有欄名一列
Set st = wb.Sheets(1)
Set wbNew = Workbooks(2) '再開要被插入新資料的活頁簿(目的excel檔)
Set stNew = wbNew.ActiveSheet
clmOrn = st.UsedRange.Columns.Count
clm = stNew.UsedRange.Columns.Count + 1 '一律從最右新欄位插入資料
cct = st.UsedRange.Columns(1).Cells.Count - 1
cnewct = stNew.UsedRange.Columns(1).Cells.Count - 1
For Each c In st.UsedRange.Columns(1).Cells '一律以第1欄作為資料比對欄'所以來源EXCEL檔必須要二欄以上
    If c.Row > 1 Then '新待插入之資料必須有欄名
'        If c.Row Mod 5000 = 0 Then stNew.Parent.Save ': Stop
        x = c.Text
'        If c.Row > 2 Then
'            If InStr(clmNewText, c) > 0 Then '目的欄位存在比對,才進行尋找插入位置
'                GoTo 11
'            Else
'                GoTo 12
'            End If
'        End If
11
'        Beep
'        Set cNew = stNew.UsedRange.Columns(1).Find(c) '要改成不找第一列!!
        'Set cNew = stNew.Range("A2:A" & cnewct + 1).Find(c) '不找第一列!!
        Set cNew = stNew.Range(stNew.Cells(2, 1), stNew.Cells(cnewct + 1, 1)).Find(c, LookAt:=xlWhole, MatchCase:=True) '不找第一列!!
        If Not cNew Is Nothing Then
        
'            cNew.Select
'            Beep
'            Stop
'            stNew.Activate
'            stNew.Cells(cNew.Row, clm + j).Select
'            Stop
'
'            If cNew.Address = "$A$1" Then '若為第一列則找下一筆!
'                beep
'                Stop
'                Set cNew = stNew.UsedRange.Columns(1).FindNext
'                If cNew Is Nothing Then flg = False: GoTo 12
'            End If
            If stNew.Cells(cNew.Row, clm + j) <> "" Then
                stNew.Activate
                beep
'                Stop
                st.Activate
                st.Cells(c.Row, 1).Select
'                Stop
                st.Cells(c.Row, clmOrn + 1) = st.Cells(c.Row, clmOrn + 1).Text & "§"   '尋找失誤的資料則註記之,以備檢
            End If
            
            For i = 2 To clmOrn '因為第一欄不插入,所以要從2開始!
                stNew.Cells(cNew.Row, clm + j) = st.Cells(c.Row, i)
                j = j + 1
            Next
            flg = True
            j = 0
            
'            Stop
            s = s + 1
        Else
            t = t + 1
            beep
'            MsgBox "CHECK!!", vbExclamation
'            Stop
            flg = False
            GoTo 12
        End If
'        For Each cNew In stNew.UsedRange.Columns(1).Cells '一律以第1欄作為資料比對欄
'            If cNew.Row > 1 Then '待被插入之資料必須有欄名
'                If StrComp(cNew.Text, x) = 0 Then
'
''                    stNew.Activate
''                    stNew.Cells(cNew.Row, clm + j).Select
''                    Stop
'
'                    For i = 2 To clmOrn
'                        stNew.Cells(cNew.Row, clm + j) = st.Cells(c.Row, i)
'                        j = j + 1
'                    Next
'                    j = 0
'                    flg = True
'
''                    Stop
'
'                    If c.Row > 2 Then Exit For
'                End If
'            End If
'            If c.Row = 2 Then clmNewText = clmNewText & cNew.Text '記下目的地比對欄內的值,以供快速比對
''            Application.StatusBar = "搜尋第" & cNew.Row & "/" & cnewct & "筆!" & vbTab & "第" & c.Row & "/" & cct & "已插入!"
''            Application.StatusBar = "搜尋第" & cNew.Row & "/" & "82131筆!" & vbTab & "第" & c.Row & "/" & "81052已插入!"
'        Next
12
        If flg = False Then '如果要插入的來源資料在目的地無對應的話
'            MsgBox "CHECK!!!!!!", vbExclamation
'            st.Activate
'            st.Cells(c.Row, 1).Select
'            Stop
            st.Cells(c.Row, clmOrn + 1) = st.Cells(c.Row, clmOrn + 1).Text & "◎" '沒有對應到的資料則註記之,以備檢
        End If
'        flg = False
    End If
    'oldStatusBar = Application.DisplayStatusBar'https://msdn.microsoft.com/zh-tw/library/office/ff835916(v=office.15).aspx
    'Application.DisplayStatusBar = True
    If (c.Row - 1) Mod 100 = 0 Or c.Row = cct + 1 Then Application.StatusBar = "第" & c.Row - 1 & "/" & cct & "已插入!"
'    Workbooks.Open Filename:="LARGE.XLS"
'    Application.StatusBar = False
'    Application.DisplayStatusBar = oldStatusBar
    u = u + 1
Next
If MsgBox("done!!" & vbCr & vbCr & "是否存檔?", vbInformation + vbYesNo + vbDefaultButton2) = vbYes Then
    If wbNew.Saved = False Then
    '    Stop
        wbNew.Save
    End If
    If wb.Saved = False Then
    '    Stop
        wb.Save
    End If
End If
Set c = Nothing
Set cNew = Nothing
Set wb = Nothing
Set wbNew = Nothing
Set st = Nothing
Set stNew = Nothing
Debug.Print "s=" & s & vbTab & "t=" & t & vbTab & "u=" & u
End Sub