✔ Programação GLOBAL®: VBA Excel - Copiando os valores de uma planilha para outra - VBA to loop through cells with date in worksheet 1, extract to worksheet 2 if month and year match

Tenho uma lista começando com uma data na primeira planilha e quero percorrê-la verificando se o mês e o ano da data na primeira coluna da lista, combinam com o mês e o ano da segunda planilha. Se assim for, a informação no resto da linha da data correspondente deve ser copiada para trabalho 2.

Há um download da planilha com alguns dados de exemplo aqui.

É possível ajustar qual dos dados são transferidos para as colunas alterando as variáveis no início.

Sub ProcessRangeData()

Dim wsSource As Worksheet

Dim wsDestination As Worksheet

Dim rowSourceStart As Long

Dim colSourceDate As Long

Dim rSource As Long

Dim colDestStart As Long

Dim rowDestMonthYear As Long

Dim cDest As Long

Dim destBlankColumnCount As Integer

Dim colDestRegion As Integer

Dim colDestAccountName As Integer

Dim colDestPotentialName As Integer

Dim colDestAmount As Integer

Dim colDestWeightedAmount As Integer

Dim colSourceRegion As Integer

Dim colSourceAccountName As Integer

Dim colSourcePotentialName As Integer

Dim colSourceAmount As Integer

Dim colSourceWeightedAmount As Integer

Set wsSource = Sheet1

Set wsDestination = Sheet2

'Destination column offsets from month column

colDestRegion = 0

colDestAccountName = 1

colDestPotentialName = 2

colDestAmount = 3

colDestWeightedAmount = 4

'Source columns

colSourceRegion = 5

colSourceAccountName = 3

colSourcePotentialName = 4

colSourceAmount = 6

colSourceWeightedAmount = 7

colSourceDate = 2 'Source column for date

rowSourceStart = 3 'Source starting row

rowDestMonthYear = 2 'Destination row to check for month & year matching

rSource = rowSourceStart

'loop until the date field on the source sheet is blank

Do While wsSource.Cells(rSource, colSourceDate).Value <> ""

cDest = 1

destBlankColumnCount = 0

'loop through the destination columns until we've seen 5 blanks

'(only 3 are ever expected)

Do Until destBlankColumnCount > 5

If wsDestination.Cells(rowDestMonthYear, cDest).Value <> "" Then

destBlankColumnCount = 0

'check if month matches

If Month(wsSource.Cells(rSource, colSourceDate).Value) = wsDestination.Cells(rowDestMonthYear, cDest).Value Then

'check if year matches

If Year(wsSource.Cells(rSource, colSourceDate).Value) = wsDestination.Cells(rowDestMonthYear, (cDest + 1)).Value Then

'copy field data

wsDestination.Cells((rowDestMonthYear + 2), (cDest + colDestAccountName)).Value = wsSource.Cells(rSource, colSourceAccountName).Value

wsDestination.Cells((rowDestMonthYear + 2), (cDest + colDestPotentialName)).Value = wsSource.Cells(rSource, colSourcePotentialName).Value

wsDestination.Cells((rowDestMonthYear + 2), (cDest + colDestRegion)).Value = wsSource.Cells(rSource, colSourceRegion).Value

wsDestination.Cells((rowDestMonthYear + 2), (cDest + colDestAmount)).Value = wsSource.Cells(rSource, colSourceAmount).Value

wsDestination.Cells((rowDestMonthYear + 2), (cDest + colDestWeightedAmount)).Value = wsSource.Cells(rSource, colSourceWeightedAmount).Value

End If

End If

Else

destBlankColumnCount = destBlankColumnCount + 1

End If

cDest = cDest + 1

Loop

rSource = rSource + 1

Loop

End Sub