在VBA Excel中複製並比較特定的單元格（注意mindbreaker !!）

Question

我有一個關於在excel中編程的非常具體的問題。我在VBA方面技術熟練，但無法擺脫這種困擾。

我有多個工作表，其中包含ID和值的列表。從這些多張工作表中，我想製作一個完整的工作表。

實施例：

表WK1

ID - Var - Var1 - Var 2 

10 - A - B - C 

14 - aa - bb- cc 

表WK2

ID - Var - Var1 - Var 2 

11 - d - e - f 

14 - AA - BB- CC 

功能必須進行以下列表

表合併

ID - WK1（瓦爾 - 瓦爾1 - 瓦爾2） - WK2（瓦爾 - 瓦爾1 - 瓦爾2）

10 - A - B - C - - - 

11 - - - - d - e - f 

14 - aa - bb - cc - AA - BB - CC 

我希望這清楚...

我覺得在第一功能必須定義每個ID是否存在。並且每個迭代的表單拷貝值在相應的列中。

目前我有以下代碼爲它工作。我必須說它正在進步，但我需要一些指針：

Sub getalldata() 

Dim MyPath As String, FilesInPath As String 
Dim MyFiles() As String 
Dim FNum As Long 
Dim mybook As Workbook 
Dim rnum As Long 
Dim ShName As Variant, BaseWks As Variant 
Dim rangearray As Variant 

' Get all data from the eight excel files in the designated directory 
' Compare Projnrs, an then paste values according in the designated slots 
' 
' Path\folder location of the files. 
MyPath = ThisWorkbook.Path & "/Source/" 

' External sheet name. To get data from 
ShName = "Report" 
' Range of columns to paste corresponding data too. sorted in per week eg {Wk1Val1, Wk1Val2 , Wk1Val3; Wk2Val1, Wk2Val2 , Wk2Val3 etc. 
rangearray = [{"D2","E2","F2";"G2","H2","I2";"J2","K2","L2";"M2","N2","O2";"P2","Q2","R2";"S2","T2","U2";"V2","W2","X2";"Y2","Z2","AA2"}] 
' Internal sheet name. To paste data too 
ShName = "Report" 


' Add a slash after MyPath if needed. 
If Right(MyPath, 1) <> "\" Then 
    MyPath = MyPath & "\" 
End If 

' If there are no Excel files in the folder, exit. 
FilesInPath = Dir(MyPath & "*.xl*") 
If FilesInPath = "" Then 
    MsgBox "No files found" 
    Exit Sub 
End If 

' Fill the myFiles array with the list of Excel files in the 
' folder. 
FNum = 0 
Do While FilesInPath <> "" 
    FNum = FNum + 1 
    ReDim Preserve MyFiles(1 To FNum) 
    MyFiles(FNum) = FilesInPath 
    FilesInPath = Dir() 
Loop 

' Change application properties. 
With Application 
    CalcMode = .Calculation 
    .Calculation = xlCalculationManual 
    .ScreenUpdating = False 
    .EnableEvents = False 
End With 

rnum = 1 

'Sort array of max 8 excel files to get wk 1 results before wk2 reuslts 
BubbleSort MyFiles 

' Loop through all files in the myFiles array. 
If FNum > 0 Then 
    For FNum = 0 To 7 
     Set mybook = Nothing 
     On Error Resume Next 
     Set mybook = Workbooks.Open(MyPath & MyFiles(FNum)) 
     On Error GoTo 0 

     If Not mybook Is Nothing Then 

      On Error Resume Next 
      ' Set the filter range. 
      ' Compare content and fill additional 


       For Each c In mybook.Worksheets("Report").Range(Cells(39, 3), Cells(65536, 3).End(xlUp)).Cells 
       If Not IsError(Application.Match(c.Value, Worksheets("Inputinfo").Range("A:A"), 0)) Then 
        ' String is in range, calculate values and paste accordingly 

        'Paste val1 (Total profit (AQ+BA)) 
        Worksheets("Inputinfo").Cells(c, 4 + FNum).Value = c.Offset(, 40).Value + c.Offset(, 50).Value 
        'Paste val2 (Not yet allocated (K+BA-(R+AV))-(AQ+BA)) 
        Worksheets("Inputinfo").Cells(c, 5 + FNum).Value = (c.Offset(, 8).Value + c.Offset(, 50).Value - (c.Offset(, 15).Value + c.Offset(, 45).Value)) - (c.Offset(, 40).Value + c.Offset(, 50).Value) 
        'Paste val3 (Net proj contri colum AT) 
        Worksheets("Inputinfo").Cells(c, 6 + FNum).Value = c.Offset(, 43).Value 
       Else 
        'String is not in range, take last used row to paste projnr and values in columns 

       End If 

       Next 

      ' Close the workbook without saving. 
      mybook.Close savechanges:=False 
     End If 

     ' Open the next workbook. 
    Next FNum 

End If 

' Restore the application properties. 
With Application 
    .ScreenUpdating = True 
    .EnableEvents = True 
    .Calculation = CalcMode 
End With 
End Sub 

有人可以指出我在正確的方向嗎？

親切的問候， Mathijs

Answer 1

Sub mergeRecords() 

Dim rng1, rng2, c As Range 
Dim r As Long 

r = 1 

「編輯

Set rng1 = Sheets("A").Range("A1:A" & Sheets("A").Range("A65536").End(xlUp).Row) 
Set rng2 = Sheets("B").Range("A1:A" & Sheets("B").Range("A65536").End(xlUp).Row) 

For Each cell In rng1 
    Set c = rng2.Find(cell.Text) 
     If c Is Nothing Then 
      Sheets("C").Range("A" & r).Value = cell.Text & "-" & cell.Offset(0, 1).Text & _ 
       "-" & cell.Offset(0, 2).Text & "-" & cell.Offset(3, 0).Text & "- - - -" 
      r = r + 1 
     Else 
      Sheets("C").Range("A" & r).Value = cell.Text & "-" & cell.Offset(0, 1).Text & _ 
       "-" & cell.Offset(0, 2).Text & "-" & cell.Offset(3, 0).Text & "-" & _ 
       c.Offset(0, 1).Text & "-" & c.Offset(0, 2).Text & "-" & c.Offset(3, 0).Text 
      r = r + 1 
     End If 
Next cell 

For Each cell In rng2 
    Set c = rng1.Find(cell.Text) 
     If c Is Nothing Then 
      Sheets("C").Range("A" & r).Value = cell.Text & "-" & cell.Offset(0, 1).Text & _ 
       "-" & cell.Offset(0, 2).Text & "-" & cell.Offset(3, 0).Text & "- - - -" 
      r = r + 1 
     End If 
Next cell 

End Sub 

也許像這樣的工作，爲你