Excel VBA根据唯一记录和工资制作不同的集合

Question

我有以下数据，

 Empid       Empname   salary   Company   location   status
    xx         Jhon      100      IBM        us   
    x1         Phil       50      IBM        us
    x2         Karl       30      IBM        us
    x3         Steve      20      IBM        us
    x4         jacob      70      Oracle     uk
    x5         jason      30      Oracle     uk
    x6         stuart     50      Oracle     uk
    zz         jay        150      Oracle    uk
   x10         Steve1     20      IBM        ind
    x9         Steve2     20      IBM        nj

我必须根据公司和位置分隔记录。所以我会得到下面两组记录。

第一组

Empid     Empname   salary   company    Location  status
    xx        Jhon             100      IBM           us   
    x1        Phil             50       IBM          us
    x2        Karl             30       IBM         us
    x3        Steve            20       IBM         us

第二组

   Empid     Empname   salary   company  Location  status
    x4        jacob      70       Oracle    uk
    x5        jason      30       Oracle    uk
    x6        stuart     50       Oracle    uk
    zz        jay       150       Oracle    uk

在上面的组中XX,zz是主记录。我检查 x1+x2+x3 是否 =xx 工资。如果相等，则我在该集的列状态中写入匹配项，否则我将忽略。原始工作表中的最后两行应忽略，因为它没有主记录。

Sub Tester()       

    Const COL_COMP As Integer = 4
    Const COL_LOC As Integer = 5
    Const VAL_DIFF As String = "XXdifferentXX"

    Dim d As Object, sKey As String
    Dim rw As Range, opt As String, rngData As Range
    Dim rngCopy As Range
    Dim FirstPass As Boolean

        With Sheet1.Range("A1")
            Set rngData = .CurrentRegion.Offset(1).Resize( _
                             .CurrentRegion.Rows.Count - 1)
        End With
        Set rngCopy = Sheet2.Range("A2")

        Set d = CreateObject("scripting.dictionary")
        FirstPass = True

redo:
        For Each rw In rngData.Rows
            sKey = rw.Cells(COL_COMP).Value & "<>" & _
                   rw.Cells(COL_LOC).Value
  'Here i have to make different sets of data.

                       Next rw
        If FirstPass Then
            FirstPass = False
            GoTo redo
        End If

    End Sub

Answer 1

如果有人面临类似问题，请使用以下解决方案

问候，
拉吉

Sub tester()

    Const COL_EID As Integer = 1
    Const COL_comp As Integer = 4
    Const COL_loc As Integer = 5
    Const COL_sal As Integer = 3
    Const COL_S As Integer = 6
    Const VAL_DIFF As String = "XXdifferentXX"

    Dim d As Object, sKey As String, sKey1 As String, id As String
    Dim rw As Range, opt As String, rngData As Range
    Dim rngCopy As Range, goodId As Boolean, goodId1 As Boolean
    Dim FirstPass As Boolean, arr, arr1

    Dim sal As Integer
    Dim colsal As Integer
    Dim mastersal As Integer
    Dim status As Boolean
    Dim status1 As Boolean

        With Sheet1.Range("A1")
            Set rngData = .CurrentRegion.Offset(1).Resize( _
                             .CurrentRegion.Rows.Count - 1)
        End With
        Set rngCopy = Sheet2.Range("A1")
         FirstPass = True
        SecondPass = False
      status = False
       Set a = CreateObject("scripting.dictionary")

        Set d = CreateObject("scripting.dictionary")


    redo:

        For Each rw In rngData.Rows

            sKey = rw.Cells(COL_comp).Value & "<>" & _
                   rw.Cells(COL_loc).Value
            sKey1 = rw.Cells(COL_comp).Value & "<>" & _
                   rw.Cells(COL_loc).Value
            colsal = rw.Cells(COL_sal).Value
            If FirstPass Then
              id = rw.Cells(COL_EID).Value
              goodId = (id = "xx" Or id = "zz")

              If d.exists(sKey) Then
                  arr = d(sKey) 'can't modify the array in situ...

                  If goodId Then arr(0) = True
                  d(sKey) = arr 'return [modified] array

              Else
                  d.Add sKey, Array(goodId)
            End If
            End If

            If SecondPass Then
              id = rw.Cells(COL_EID).Value
              goodId1 = (id = "xx" Or id = "zz")

             If d(sKey)(0) = True Then
             If goodId1 Then mastersal = rw.Cells(COL_sal).Value
             If a.exists(sKey1) Then
                  arr1 = a(sKey1) 'can't modify the array in situ...

                  If goodId1 = False Then sal = sal + colsal
                   If mastersal = sal Then arr1(0) = True



                  'If goodId1 Then arr1(0) = True
                  a(sKey1) = arr1 'return [modified] array

              Else
                  a.Add sKey1, Array(status)
                  sal = 0
                   If goodId1 = False Then sal = sal + colsal
            End If

            End If
            End If

             If FirstPass = False And SecondPass = False Then
            If d(sKey)(0) = True Then
              If a(sKey1)(0) = True Then
                  rw.Copy rngCopy
                  Set rngCopy = rngCopy.Offset(1, 0)
             End If
            End If
            End If


        Next rw
        If SecondPass Then
            SecondPass = False
            GoTo redo
        End If
        If FirstPass Then
            FirstPass = False
            SecondPass = True
            colsal = 0
            GoTo redo
        End If

    End Sub