Linking-updating worksheets?

[lolos]

I have a workbook with a MAIN worksheet with columns: INVOICE ID, DATE PURS, CLIENTS, PROD ID, PCS, PRICE.The sorting is made by INVOICE ID.

The other worksheets are clients.

When I add a new row in the MAIN worksheet I want depending on the entry at CLIENTS column to add this row to the specific client worksheet.

Any ideas?
I have excel 2007.
__________________

[RonMcK]

<deleted>

[rbrhodes]

Hi lolos,

This is worksheet code so open the Sheet Module for sheet "MAIN" and paste this in (Right click on the "MAIN" sheet tab and choose view code, paste this code there).

It will add the row to the relevant sheet when all 5 columns are filled in. NOTE: You can change the Columns - see Comments in code.

You didn't mention anything about changing an existing line so I didn't code for that - IF you edit a line it will simply add the changed line to the relevant sheet each time any cell in the line is changed...


Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim eCol As Long
Dim cCol As Long
Dim sCol As Long
Dim tRow As Long
Dim cel As Range
Dim cRng As Range
Dim LastRow As Long
Dim tSheet As String
' //Set Columns here
' Set Start Column
sCol = 1

' Set End Column
eCol = 6

' Set CLIENTS Column
cCol = 3

' //End

' Get current row
tRow = Target.Row

' Check if we're in Cols
If Not Intersect(Target, Range(Cells(tRow, sCol), Cells(tRow, eCol))) Is Nothing Then
' Turn off screen refresh
Application.ScreenUpdating = False
' Yes. Check if all 5 Cols complete
Set cRng = Range(Cells(tRow, sCol), Cells(tRow, eCol))
For Each cel In cRng
If cel = "" Then
Exit Sub
End If
Next cel
' Get relevant sheet
tSheet = Cells(tRow, cCol)
'Handle missing sheets, bad sheet name...
On Error Resume Next
' Get last row of data on that sheet
LastRow = Sheets(tSheet).Range("A65536").End(xlUp).Row + 1
If Err = 0 Then
' Copy to sheet
Range(Cells(tRow, sCol).Address, Cells(tRow, eCol).Address).Copy Destination:=Sheets(tSheet).Range("A" & LastRow)
Else
' No errors
Err.Clear
On Error GoTo 0
' Inform User
tSheet = MsgBox("Sheets " & tSheet & " not found", vbCritical)
End If
End If
' Reset
Set cel = Nothing
Set cRng = Nothing
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With

End Sub

[lolos]

Hi,
thank you for your reply!
I have to admit i am not so familiar with code.

So what i have is:
the first worksheet is Invoices.(i add a row after each sell).
the other worksheets are customers (only 2 for the exemple but x in real).
the columns are 6 for the example but more in real.

So i need to add a new Invoices (row) and add the new invoice (row) in the appropriate customer worksheet.
Also i need to add new columns and update the old ones(example: i add new column "payed or not" so when the invoice is payed after one month i go back check column payd and update also the customer worksheet.

Thank you in advance, lolos!

[lolos]

I found this code!!!

Sub ExtractReps()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("MAIN")
Set rng = Range("A:AG")

'extract a list of Sales Reps
ws1.Columns("F:F").Copy _
Destination:=Range("CA1")
ws1.Columns("CA:CA").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("BY1"), Unique:=True
r = Cells(Rows.Count, "BY").End(xlUp).Row

'set up Criteria Area
Range("CA1").Value = Range("F1").Value

For Each c In Range("BY2:BY" & r)
'add the rep name to the criteria area
ws1.Range("CA2").Value = c.Value
'add new sheet (if required)
'and run advanced filter
If WksExists(c.Value) Then
Sheets(c.Value).Cells.Clear
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("MAIN").Range("CA1:CA2"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Unique:=False
Else
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("MAIN").Range("CA1:CA2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
End If
Next
ws1.Select
ws1.Columns("BY:CA").Delete
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function


Any chance adding the SUM function in the last row in each new worksheet BUT only in selected columns?

[rbrhodes]

Hi lolos,

Yes.




<snip>

Else
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("MAIN").Range("CA1:CA2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
End If

'The code for the Sum Formula would go here

<snip>

[lolos]

Hi rbrhodes,
I try to put it in but i get Compile errors or other kind off.

As you can tell i am not so familiar so if you can tell me where to snip it and the formula to write, i will be gratefull!
Kind regards.

[rbrhodes]

Hi,

Here's your code with some comments etc.


Option Explicit
Sub ExtractReps()

'//Add a variable for Last Row of data on new sheet
Dim LastRow As Long
'//
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range

Set ws1 = Sheets("MAIN")
Set rng = Range("A:AG")

'extract a list of Sales Reps
ws1.Columns("F:F").Copy _
Destination:=Range("CA1")
ws1.Columns("CA:CA").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("BY1"), Unique:=True
r = Cells(Rows.Count, "BY").End(xlUp).Row

'set up Criteria Area
Range("CA1").Value = Range("F1").Value

For Each c In Range("BY2:BY" & r)
'//Check for value in cell
If Not c.Value Is Nothing Then

'add the rep name to the criteria area
ws1.Range("CA2").Value = c.Value
'add new sheet (if required)
'and run advanced filter
If WksExists(c.Value) Then
Sheets(c.Value).Cells.Clear
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("MAIN").Range("CA1:CA2"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Unique:=False
Else
'//Here's where the new sheet gets added
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("MAIN").Range("CA1:CA2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
'//Here's where the Sum formula gets added
' Get last row of data Col A (or wherever)
LastRow = Range("A65536").End(xlUp).Row + 1

' Put Sum formula in Col A (or wherever)
Cells(LastRow, 1) = "=Sum(A1:A" & LastRow - 1 & ")"
End If
End If
Next
With ws1
.Select
.Columns("BY:CA").Delete
End With
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

[lolos]

I am sorry but it dosent work.
When i run it it give:run time error 424 and get yellow at: If Not c.Value Is Nothing Then
After i dont know
Any ideas?

[rbrhodes]

Oops!

Change

If Not c.Value Is Nothing Then

to

If c.value <> "" then

[lolos]

Ok i change that and now it is runing, BUT,
I also change'//Here's where the Sum formula gets added
' Get last row of data Col A (or wherever)
LastRow = Range("K65536").End(xlUp).Row + 1

' Put Sum formula in Col A (or wherever)
Cells(LastRow, 1) = "=Sum(K1:K" & LastRow - 1 & ")"

Where A column is now K and it is always suming A and second whene i run it second time it makes the new sheets with more rows if i add but dosent sum nothing!