Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- Sub saveMaxAndDate()
- Dim resWorksheet As Worksheet, objectsWorksheet As Worksheet, debitWorksheet As Worksheet
- Set resWorksheet = Worksheets("Sheet3")
- Set objectsWorksheet = Worksheets("Sheet2")
- Set debitWorksheet = Worksheets("Sheet1")
- Dim row As Integer, j As Integer
- Dim max As Double
- Dim maxDate As Date
- Dim maxObjects As String
- Dim commaPos As Integer, commaPosNext As Integer
- Dim startMutual As Boolean
- Dim mutualBeginDate As Date, mutualEndDate As Date
- Dim currentMutualCol As Integer
- For row = 2 To debitWorksheet.Range("C2").End(xlDown).row
- resWorksheet.Cells(row, 1) = debitWorksheet.Cells(row, 3)
- col = 2
- max = -1
- startMutual = False
- currentMutualCol = 5
- Do While Not IsEmpty(debitWorksheet.Cells(1, col + 2))
- If Not IsEmpty(debitWorksheet.Cells(row, col + 2)) And debitWorksheet.Cells(row, col + 2).Value > max Then
- max = debitWorksheet.Cells(row, col + 2).Value
- maxDate = debitWorksheet.Cells(1, col + 2).Value
- maxObjects = objectsWorksheet.Cells(row, col + 2).Value
- End If
- commaPos = InStr(objectsWorksheet.Cells(row, col + 2).Value, ",")
- commaPosNext = InStr(objectsWorksheet.Cells(row, col + 3).Value, ",")
- If startMutual Then
- If IsEmpty(objectsWorksheet.Cells(row, col + 3)) Or commaPosNext = 0 Then
- startMutual = False
- mutualEndDate = objectsWorksheet.Cells(1, col + 2).Value
- resWorksheet.Cells(row, currentMutualCol+1) = mutualEndDate
- resWorksheet.Cells(row, currentMutualCol+2) = objectsWorksheet.Cells(row, col + 2).Value
- currentMutualCol = currentMutualCol+3
- End If
- End If
- If Not IsEmpty(objectsWorksheet.Cells(row, col + 2)) Then
- If Not startMutual And commaPos <> 0 And commaPosNext <> 0 Then
- startMutual = True
- mutualBeginDate = objectsWorksheet.Cells(1, col + 2).Value
- resWorksheet.Cells(row, currentMutualCol) = mutualBeginDate
- End If
- End If
- col = col + 1
- Loop
- If max > 0 Then
- resWorksheet.Cells(row, 2) = max
- resWorksheet.Cells(row, 3) = maxDate
- resWorksheet.Cells(row, 4) = maxObjects
- End If
- Next row
- End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement