A Macro to Fill data from Master table to individual sheet

[Dilusha]

[TABLE="class: grid, width: 50"]
<tbody>[TR]
[TD]Cus_Code(Column A)
[/TD]
[TD]Name (Column B)
[/TD]
[TD]TIN (Column C)
[/TD]
[TD]VAT (Column D)
[/TD]
[TD]Rs.(Column E)
[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]BBE
[/TD]
[TD]ABC Perra
[/TD]
[TD]104074472
[/TD]
[TD]SVAT001084
[/TD]
[TD]2550
[/TD]
[TD]Row1
[/TD]
[/TR]
[TR]
[TD]BTE
[/TD]
[TD]D. KAMAL
[/TD]
[TD]114169161
[/TD]
[TD]SVAT000585
[/TD]
[TD]3256
[/TD]
[TD]Row2
[/TD]
[/TR]
[TR]
[TD]DSL
[/TD]
[TD]L.SUNIL
[/TD]
[TD]114337617
[/TD]
[TD]103256
[/TD]
[TD]2456
[/TD]
[TD]Row3
[/TD]
[/TR]
[TR]
[TD]ELS
[/TD]
[TD]F.SILVA
[/TD]
[TD]114089087
[/TD]
[TD]SVAT000550
[/TD]
[TD]11000
[/TD]
[TD]Row4
[/TD]
[/TR]
[TR]
[TD]EVE
[/TD]
[TD]L.SILVA
[/TD]
[TD]104072488
[/TD]
[TD]SVAT001890
[/TD]
[TD]25000
[/TD]
[TD]Row5
[/TD]
[/TR]
</tbody>[/TABLE]

I have this table in sheet1 & i have created sheets for each customer by name of its CUS_CODE in same work book.
Now I want a macro to copy this data and paste in relevant sheet & relevant cell as follows.

Name should be pasted in I19 in every sheet.
TIN should be pasted in I17 every sheet
VAT should be pasted in I16 every sheet
RS should be pasted in j29 every sheet

EG. 3256 shuould be printed on J29 in BTE sheet.

There is no duplicate Cus_Code & I Use excel 2007.

please help me .

 

[JackDanIce]

Try:

Sub M1()

    Dim arr()       As Variant
    Dim x           As Long
    Dim headerRow   As Long
        
    headerRow = 1
    arr = sheets("Sheet1").Cells(headerRow + 1, 1).Resize(Cells(Rows.Count, 1).End(xlUp).Row - headerRow + 1, 5).Value
    
    For x = LBound(arr, 1) To UBound(arr, 1)
        With sheets(arr(x, 1))
            'VAT
            .Cells(16, 9).Value = arr(x, 4)
            'TIN
            .Cells(17, 9).Value = arr(x, 3)
            'Name
            .Cells(19, 9).Value = arr(x, 2)
            'RS
            .Cells(29, 10).Value = arr(x, 5)
        End With
    Next x
    
    Erase arr
    
End Sub

 

[Dilusha]

thanks .but error
Run time error9
subscript out of range

 

[JackDanIce]

On what line is that error?

 

[Dilusha]

On what line is that error?

until With Sheets(arr(x, 1)) is ok

 

[Dilusha]

when press f8 after " With Sheets(arr(x, 1))" the error appears .

 

[JackDanIce]

It may be your cell value is not matching the sheet name exactly, try:

Sub M1()


    Dim arr()       As Variant
    Dim x           As Long
    Dim headerRow   As Long
    Dim wks         As Worksheet
    headerRow = 1
    arr = sheets("Sheet1").Cells(headerRow + 1, 1).Resize(Cells(Rows.Count, 1).End(xlUp).Row - headerRow + 1, 5).Value
    
    For x = LBound(arr, 1) To UBound(arr, 1)
        On Error Resume Next
        Set wks = sheets(arr(x, 1))
        On Error GoTo 0
        If Not wks Is Nothing Then
            With wks
            
                'VAT
                .Cells(16, 9).Value = arr(x, 4)
                'TIN
                .Cells(17, 9).Value = arr(x, 3)
                'Name
                .Cells(19, 9).Value = arr(x, 2)
                'RS
                .Cells(29, 10).Value = arr(x, 5)
            End With
            Set wks = Nothing
        End If
    Next x
    
    Erase arr
    
End Sub

 

[Dilusha]

It may be your cell value is not matching the sheet name exactly, try:

Sub M1()


    Dim arr()       As Variant
    Dim x           As Long
    Dim headerRow   As Long
    Dim wks         As Worksheet
    headerRow = 1
    arr = sheets("Sheet1").Cells(headerRow + 1, 1).Resize(Cells(Rows.Count, 1).End(xlUp).Row - headerRow + 1, 5).Value
    
    For x = LBound(arr, 1) To UBound(arr, 1)
        On Error Resume Next
        Set wks = sheets(arr(x, 1))
        On Error GoTo 0
        If Not wks Is Nothing Then
            With wks
            
                'VAT
                .Cells(16, 9).Value = arr(x, 4)
                'TIN
                .Cells(17, 9).Value = arr(x, 3)
                'Name
                .Cells(19, 9).Value = arr(x, 2)
                'RS
                .Cells(29, 10).Value = arr(x, 5)
            End With
            Set wks = Nothing
        End If
    Next x
    
    Erase arr
    
End Sub

now it works .
thanks a lot

 

[JackDanIce]

You're welcome