terça-feira, maio 03, 2005

Transferência de dados entre pastas, criando um histórico

"Basta sermos simples para sermos ricos em nossos atos!" (E.S.P.)
----------

Private Sub Worksheet_Change(ByVal Target As Range)
'
'Autor: Eneias dos Santos Pedroso
'
For Each Item In Target
If Target.Row = 1 Then Exit Sub
If Target.Column = 1 Then
For j = 0 To 100 'Aumentar o intervalo de linhas (onde há o 100)
If Item.Value <> "" Then
Windows("Nome da pasta com o histórico.xls").Activate
'Mude o nome da pasta acima
If Worksheets(1).Cells(j + 1, 1) = "" Then
Worksheets(1).Cells(j + 1, 1) = Item
Windows("Nome da pasta que recebe os dados.xls").Activate
'Mude o nome da pasta acima
Exit For
End If: End If: Next j: End If

If Target.Row = 1 Then Exit Sub
If Target.Column = 2 Then
For k = 0 To 100 'Aumentar o intervalo de linhas (onde há o 100)
If Item.Value <> "" Then
Windows("Nome da pasta com o histórico.xls").Activate
'Mude o nome da pasta acima
If Worksheets(1).Cells(k + 1, 2) = "" Then
Worksheets(1).Cells(k + 1, 2) = Item
Windows("Nome da pasta que recebe os dados.xls").Activate
'Mude o nome da pasta acima
Exit For
End If: End If: Next k: End If

If Target.Row = 1 Then Exit Sub
If Target.Column = 3 Then
For m = 0 To 100 'Aumentar o intervalo de linhas (onde há o 100)
If Item.Value <> "" Then
Windows("Nome da pasta com o histórico.xls").Activate
'Mude o nome da pasta acima
If Worksheets(1).Cells(m + 1, 3) = "" Then
Worksheets(1).Cells(m + 1, 3) = Item
Windows("Nome da pasta que recebe os dados.xls").Activate
'Mude o nome da pasta acima
Exit For
End If: End If: Next m: End If

If Target.Row = 1 Then Exit Sub
If Target.Column = 4 Then
For n = 0 To 100 'Aumentar o intervalo de linhas (onde há o 100)
If Item.Value <> "" Then
Windows("Nome da pasta com o histórico.xls").Activate
'Mude o nome da pasta acima
If Worksheets(1).Cells(n + 1, 4) = "" Then
Worksheets(1).Cells(n + 1, 4) = Item
Windows("Nome da pasta que recebe os dados.xls").Activate
'Mude o nome da pasta acima
Exit For
End If: End If: Next n: End If
Next Item

End Sub

----------
Maiores esclarecimentos, acesse o link que está no título deste post !

Nenhum comentário: