VBA - Problema com um código de Sheet Change Event

Question

Bom dia,

Eu estou a tentar implementar um código que me permite fazer passar informação que está em células de uma 'Sheet1' para uma 'Sheet2', de acordo com um DropDown List  presente na 'Sheet2'.

O problema é que o código que desenvolvi não consegue passar informação para a Sheet2. Penso que o problema é a posição das colunas e das tabelas, mas não consigo resolver...

Alguém me consegue ajudar?

Em seguida segue o código:

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.CountLarge > 1 Then Exit Sub
Dim wsSource As Worksheet
Dim r As Long
Set wsSource = Sheets("Sheet1")     
If Target.Column = 1 And Target.Row > 1 Then
    Application.EnableEvents = False
    If Target <> "" Then
        If Application.CountIf(wsSource.Columns(1), Target.Value) > 0 Then
            r = Application.Match(Target.Value, wsSource.Columns(1), 0)
            wsSource.Range("D" & r & ":L" & r).Copy Target.Offset(0, 1)
            Target.Offset(0, 1) = wsSource.Cells(r, 2)
        End If
    Else
        Target.Resize(1, 5).ClearContents
    End If
    Application.EnableEvents = True
End If
End Sub

Como a minha conta ainda não está verificada, ainda não posso colocar imagens ou links :(

Mas vou tentar explicar da melhor forma como se encontram as tabelas.

Na sheet1:

A informação que está definida como um 'Nome' que vai ser utilizada na DropDown List está na coluna C;

A informação que é para ser passada para a sheet2 de acordo com a dropdown list está entre as colunas D e L, e nas linhas 4 a 88;

Na sheet2:

A dropdown list está presente na coluna B, entre as linhas 7 e 100;

A informação preenchida automaticamente pela dropdown list tem que estar presente entre as colunas C e K e entre as linhas 7 e 100;

Obrigado pela ajuda,

JuveLuis

Answer 1

Continua a não funcionar. Só funciona se a tabela base (Sheet1) estiver na posição (A,1). 

Posso mandar um link do imgur a exemplificar a tabela base? Como não posso colocar links directamente, punha o link assim: http: // imgur. com/ gallery/XXX ? 

Answer 2

Esta é a imagem da minha Sheet1:

http://imgur.com/a/Qxfi7

Tal como disse, julgo que o problema esteja aqui: 

    If Target <> "" Then
        If Application.CountIf(wsSource.Columns(1), Target.Value) > 0 Then
            r = Application.Match(Target.Value, wsSource.Columns(1), 0)
            wsSource.Range("D" & r & ":L" & r).Copy Target.Offset(0, 1)
            Target.Offset(0, 1) = wsSource.Cells(r, 2)

Answer 3

Fiz o teste aqui e colou o conteúdo de uma linha:

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.CountLarge > 1 Then Exit Sub
Dim wsSource As Worksheet
Dim r As Long
Set wsSource = Sheets("Sheet1")
If Target.Column = 1 And Target.Row > 1 Then
    Application.EnableEvents = False
    If Target <> "" Then
        If Application.CountIf(wsSource.Columns(1), Target.Value) > 0 Then
            r = Application.Match(Target.Value, wsSource.Columns(1), 0)
            wsSource.Range("D" & r & ":L" & r).Copy
            Target.Offset(0, 1).Select
            ActiveSheet.Paste
            Target.Offset(0, 1) = wsSource.Cells(r, 2)
        End If
    Else
        Target.Resize(1, 5).ClearContents
    End If
    Application.EnableEvents = True
End If
End Sub

---

Anderson Diniz