VBA help

[sa.1985]

Dear All,


I have created a column as id number, Sheetname "Dataentry"'s rows data will transfer in same id number's sheets ( other sheets name i given as ID )


Cell A1 = 1 ( 1 is id number )

Cell A2 = 2 ( 2 is id number )

Cell A3 = 3 ( 3 is id number )

Cell A4 = 1 ( Repeated id number )

Cell A5 = 2 ( Repeated if number )


as above i mentioned in column A:A is id number , Here i want.........

if cell A1 = 1 then this row's data transfer to sheetname 1

if cell A2 = 2 then this row's data transfer to sheetname 2

if cell A3 = 3 then this row's data transfer to sheetname 3


if cell A4 = 1 then this row's data transfer to sheetname 1 ( this is repeated )

 

[mercatog]

Hi

Run the sub Tansfer (I guess that your destination sheets name is 1, 2,...etc)

[pre]

Sub Transfer()
Dim LastRow As Long, i As Long
Dim ShtName As String

Application.ScreenUpdating = False
With Worksheets("Dataentry")
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 1 To LastRow
ShtName = CStr(.Range("A" & i))
If SheetExists(ShtName) Then .Rows(i).Copy Worksheets(ShtName).Cells(Worksheets(ShtName).Rows.Count, 1).End(xlUp)(2)
Next i
End With
End Sub

Private Function SheetExists(ByVal Str As String) As Boolean
Dim Sh As Worksheet

If Str <> "" Then
For Each Sh In ThisWorkbook.Worksheets
If Sh.Name = Str Then
SheetExists = True
Exit For
End If
Next Sh
End If
End Function

[/pre]

Regards

 

[sa.1985]

Dear Sir


Thank u so much, but here a problem that ...


when i enter second entry by same id ( for example id no : 1) in data entry sheet then sheetname 1's entry increasing , it should not to be .

 

[mercatog]

That means you want to copy only the last row of the same id?

please confirm


Regards!

 

[sa.1985]

Yes sir

 

[mercatog]

Here the code modified

[pre]

Sub Transfer()
Dim LastRow As Long, i As Long
Dim ShtName As String, Result As String

Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Dataentry")
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = LastRow To 1 Step -1
ShtName = CStr(.Range("A" & i))
If InStr(Result, "," & ShtName) = 0 Then
If SheetExists(ShtName) Then
.Rows(i).Copy Worksheets(ShtName).Range("A1")
Result = Result & "," & ShtName
End If
End If
Next i
End With
End Sub

Private Function SheetExists(ByVal Str As String) As Boolean
Dim Sh As Worksheet

If Str <> "" Then
For Each Sh In ThisWorkbook.Worksheets
If Sh.Name = Str Then
SheetExists = True
Exit For
End If
Next Sh
End If
End Function

[/pre]