Transfering data

[tofimoon4]

Dear sir,with my regards,like to thank you for your help and wonderful
solution which encouraged me to send another file asking for another
help to transfer datas from main sheet to (12) sheets being the twelve
months (without duplicates the transferred data).
Many thanks in advance.


+-------------------------------------------------------------------+
|Filename: Transferring.zip |
|Download: http://www.thecodecage.com/forumz/attachment.php?attachmentid=145|
+-------------------------------------------------------------------+

 

[Joel]

I just checked to make sure duplicate invoice numbers where not copied

Sub transferdata()


With Sheets("Main")
RowCount = 5
Start = RowCount
LastRow = .Range("A" & Rows.Count).End(xlUp).Row

Do While RowCount <= LastRow
If .Range("C" & RowCount) <> "" Then
Invoice = .Range("C" & RowCount)
End If
If RowCount = LastRow Or _
.Range("B" & (RowCount + 1)) Then

MyMonth = Month(.Range("B" & RowCount))
With Sheets(MyMonth)
Set c = .Columns("C").Find(what:=Invoice, _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
NewRow = .Range("B" & Rows.Count).End(xlUp).Row + 1
Sheets("main").Rows(Start & ":" & RowCount).Copy _
Destination:=.Rows(NewRow)
Start = RowCount + 1
End If
End With
RowCount = RowCount + 1
End If
RowCount = RowCount + 1
Loop
End With


End Sub

 

[Joel]

I found some rrors. Didnt check the result very carefully the 1st time

Sub transferdata()

Dim MyMonth As String

For Each sht In Sheets
If sht.Name <> "main" Then
sht.Rows("5:" & Rows.Count).Delete
End If

Next sht

With Sheets("Main")
RowCount = 5
Start = RowCount
LastRow = .Range("A" & Rows.Count).End(xlUp).Row

Do While RowCount <= LastRow
If .Range("C" & RowCount) <> "" Then
Invoice = .Range("C" & RowCount)
End If
If RowCount = LastRow Or _
.Range("C" & (RowCount + 1)) <> "" Then

MyMonth = Month(.Range("B" & RowCount))
With Sheets(MyMonth)
Set c = .Columns("C").Find(what:=Invoice, _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
NewRow = .Range("B" & Rows.Count).End(xlUp).Row + 1
If NewRow = 4 Then
NewRow = 5
End If
Sheets("main").Rows(Start & ":" & RowCount).Copy _
Destination:=.Rows(NewRow)
Start = RowCount + 1
End If
End With

End If
RowCount = RowCount + 1
Loop
End With


End Sub

 

[Joel]

Sub transferdata()

Dim MyMonth As String

For Each sht In Sheets
If sht.Name <> "main" Then
sht.Rows("5:" & Rows.Count).Delete
End If

Next sht

With Sheets("Main")
RowCount = 5
Start = RowCount
LastRow = .Range("A" & Rows.Count).End(xlUp).Row

Do While RowCount <= LastRow
If .Range("C" & RowCount) <> "" Then
Invoice = .Range("C" & RowCount)
End If
If RowCount = LastRow Or _
.Range("C" & (RowCount + 1)) <> "" Then

MyMonth = Month(.Range("B" & RowCount))
With Sheets(MyMonth)
Set c = .Columns("C").Find(what:=Invoice, _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
NewRow = .Range("B" & Rows.Count).End(xlUp).Row + 1
If NewRow = 4 Then
NewRow = 5
End If
Sheets("main").Rows(Start & ":" & RowCount).Copy _
Destination:=.Rows(NewRow)
Start = RowCount + 1
End If
End With

End If
RowCount = RowCount + 1
Loop
End With


End Sub

 

[Don Guillett]

Should do it. Even adjusts for the fact that you did not delete row 4 as
instructed before. Do NOT delete now as it will ruin the macro. Send me your
email and I'll send the file as we don't attach files where I answered in
the ms news group.

Sub filterbymonthandcopytosheets()
Application.ScreenUpdating = False
Range("b4") = 0
lr = Cells(Rows.Count, "b").End(xlUp).Row

For i = 5 To lr
Cells(i, 1).Value = Month(Cells(i, 2))
Next i

With Range("a2:i" & lr)
For i = 1 To Cells(lr, 1)
.AutoFilter Field:=1, Criteria1:=i
.Offset(2, 1).Copy
With Sheets(CStr(i)).Range("b5")
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteValues
End With
Next i
.AutoFilter
End With

Columns(1).ClearContents
Application.ScreenUpdating = True
End Sub

 

[Don Guillett]

Joel,
Did we read the same post?

 

[tofimoon4]

Dear friends,many thanks for help.
1-Mr.Don : with my appreciation to your solution ,there is only one
note about the ( total ) column which doesnot appear in( main )sheet and
all( months sheets) transferred invoices.
-My e.mail is ( (e-mail address removed)).
2-Mr.Joel : with my admiration in your solution ,i think there is a
problem in A- ( sheet 12 ) after transferring data B- the months
sheets after 5 sheet , if you can check the result of transferring the
data .
Hopping to recieve any amendments for the codes which help me to reach
the target.
My regards.

 

[donaldb36]

I don't understand your response...

 

[tofimoon4]

Dear sir,you are hero,i am so lucky to see you on this wonderful
forum,thank you very much for help,everything is excellent.

 

[Don Guillett]

Glad to help

 

[tofimoon4]

Dear sir,with my apology,i found after some expriences that the sheets
(6,7,8,10) which i coloured in yellow in attached file have a mistake.
Asking you kindly to take a look and modify.
thanks in advance.


+-------------------------------------------------------------------+
|Filename: Transferring1.zip |
|Download: http://www.thecodecage.com/forumz/attachment.php?attachmentid=146|
+-------------------------------------------------------------------+

 

[Don Guillett]

Only filters if month in col J

Sub clearsheets()
For Each ws In Worksheets
If UCase(ws.Name) <> "MAIN" Then ws.Rows("5:1000").ClearContents
Next
End Sub

Sub filterbymonthandcopytosheetsSAS()
Application.ScreenUpdating = False
clearsheets

Range("b4") = 0
lr = Cells(Rows.Count, "b").End(xlUp).Row

For i = 5 To lr
Cells(i, "J").Value = Month(Cells(i, 2))
Next i

With Range("a2:j" & lr)
For i = 1 To 12

If Application.CountIf(Columns("j"), i) > 0 Then
.AutoFilter Field:=10, Criteria1:=i

Range(Cells(5, "b"), Cells(lr, "i")).Copy
With Sheets(CStr(i)).Range("b5")
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteValues

End With
End If

Next i
.AutoFilter
End With
Columns("j").ClearContents
Application.ScreenUpdating = True
End Sub

 

[tofimoon4]

Thank you my sir , you are genius really.

 

[Don Guillett]

Glad to help