Thanks you all;
Resolved:
In module;
Public Const columnConselho = 7
'By JPaulo Janeiro 2010
Public Function getColNumber(ByVal strCell As String) As String
Dim charC As Integer
charC = InStrRev(strCell, "C")
getColNumber = Mid$(strCell, charC + 1)
End Function
Public Function getRowNumber(ByVal strCell As String) As String
Dim charC As Integer, charR As Integer
charC = InStrRev(strCell, "C")
charR = InStr(strCell, "R")
getRowNumber = Mid$(strCell, charR + 1, charC - charR - 1)
End Function
Public Function DLExcelFileExists(fname) As Boolean
Dim x As String
x = Dir(fname)
If x <> "" Then DLExcelFileExists = True Else: DLExcelFileExists = False
End Function
Public Function DLExcelGetFirstFreeRow(ByVal strSheet As String, ByVal firstLine As Integer, ByVal lastLine As Double, ByVal colToCheck As Integer) As Integer
For i = firstLine To lastLine
If Worksheets(strSheet).Cells(i, colToCheck).Value = "" Then
DLExcelGetFirstFreeRow = i
Exit Function
End If
Next
DLExcelGetFirstFreeRow = 0
End Function
Public Function DLExcelGetWorkbookIndex(ByVal BookName As String) As Integer
For i = 1 To Workbooks.Count
If LCase$(Workbooks.Item(i).Name) = LCase$(BookName) Then
DLExcelGetWorkbookIndex = i
Exit Function
End If
Next i
DLExcelGetWorkbookIndex = -1
End Function
Public Sub CopiaLinha(ByVal Target As Range)
Dim MyWorkBook As String
MyWorkBook = ActiveWorkbook.Name
'Descobrir a coluna em que estamos
Dim colNumber As Integer
colNumber = getColNumber(Target.Address(ReferenceStyle:=xlR1C1, RowAbsolute:=True, ColumnAbsolute:=True))
If colNumber < 1 Then Exit Sub
'Descobrir o nome do conselho
Dim NomeConselho As String
If colNumber = columnConselho Then NomeConselho = Target.Cells(1, 1).Value
If NomeConselho = "" Then Exit Sub
'Definir o ficheiro e ver se existe
Dim filePath As String
filePath = ActiveWorkbook.Path & "\" & NomeConselho & ".xls"
If Not DLExcelFileExists(filePath) Then
MsgBox "Livro nao encontrado"
Exit Sub
End If
'Abrir o livro, ver qual a 1ª linha vazia e posicionar nessa linha
Workbooks.Open (filePath)
Dim firstFreeRow As Double
firstFreeRow = DLExcelGetFirstFreeRow(ActiveSheet.Name, 4, 65000, 1)
ActiveSheet.Cells(firstFreeRow, 1).Select
'Voltar ao livro original e copiar a linha seleccionada
Workbooks.Item(DLExcelGetWorkbookIndex(MyWorkBook)).Activate
Dim rowNumber As Integer
rowNumber = getRowNumber(Target.Address(ReferenceStyle:=xlR1C1, RowAbsolute:=True, ColumnAbsolute:=True))
ActiveSheet.Rows(rowNumber).Copy
'Voltar ao 2º, colar e fechar
Workbooks.Item(DLExcelGetWorkbookIndex(NomeConselho & ".xls")).Activate
ActiveSheet.Paste
ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub
In Sheet;
Private Sub Worksheet_Change(ByVal Target As Range)
CopiaLinha Target
End Sub