Insert data another book if

JPaulo

Developer
Local time
Today, 19:00
Joined
Dec 21, 2009
Messages
185
Hi all;

I have BookGeral and 4 more books, BookA, BookB, BookC and BookD

If I digit in BookGeral cell A1 = "A" automatic insert data in livroA
If I digit in BookGeral cell A1 = "B", automatic insert data in livroBAll books are in the same folder C: \ Test

Help me please
 
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
 
Hi, JPaulo,

Code:
With Target
    If .Count = 1 Then
      Debug.Print "Column: " & .Column & vbTab & "Row: " & .Row
    End If
End With
Ciao,
Holger
 

Users who are viewing this thread

Back
Top Bottom