0

我有一个关于 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(Var - Var 1 - Var 2) - wk2(Var - Var 1 - Var 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

有人可以指出我正确的方向吗？

亲切的问候， 马蒂斯

4

1 回答 1

0 
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

也许这样的事情对你有用

于 2013-08-19T14:24:43.170 回答