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




Sim, é básico, mas satisfaz. Pelo menos àqueles que têm pouca experiência.

No código abaixo aprenderemos como usar o looping num range de células, extraindo deste os resultados desejados, transferindo-os a outra planilha.

Exemplo:
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

Tags: Range, Excel, VBA, copy, worksheet,



Nenhum comentário:

Postar um comentário

diHITT - Notícias