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 являются основными записями. Я проверяю, х1 + х2 + х3 = хх зарплата. Если он равен, то я пишу как соответствует в статусе столбца для этого набора, в противном случае я игнорирую Последние две строки в исходных листах следует игнорировать, поскольку в них нет основной записи.

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