Copy Data to multiple Worksheet Based on cell values

[Negi1984]

Hi All,

I have an workbook. and below sheets contains :-

1) RAMSES : this is main sheet from where I need to copy only column F and paste in multiple sheets. based on cell value mentioned in column C.

2) CTA : data needs to paste in this sheet if any cell value of column C in Ramses is mentioned as "CTA"

3) IDF : data needs to paste in this sheet if any cell value of column C in Ramses is mentioned as "IDF"

4) MED : data needs to paste in this sheet if any cell value of column C in Ramses is mentioned as "MED"

5) NOE : data needs to paste in this sheet if any cell value of column C in Ramses is mentioned as "NOE"

6) SWT : data needs to paste in this sheet if any cell value of column C in Ramses is mentioned as "SWT"

7) WST : data needs to paste in this sheet if any cell value of column C in Ramses is mentioned as "WST"

8) BLANK : data needs to paste in this sheet if any cell value of column C in Ramses is mentioned as "#N/A" or any Blank Cell in column C in Ramses.

I have attached the sample file as well in below link.
https://1drv.ms/x/s!Ap80Ku6M2Tw5gTbGRwA5Q6nGCIGO

Thanks in advance for your valuable support.

Regards,
Rajender

 

[PCL]

It seems there is no header in tabs !!

 

[Fluff]

How about

Sub CopyFltr()
   Dim Ary As Variant
   Dim i As Long
   
   Ary = Array("CTA", "IDF", "MED", "NOE", "SWT", "WST", "#N/A")
   
   With Sheets("Ramses")
      If .AutoFilterMode Then .AutoFilterMode = False
      For i = 0 To UBound(Ary) - 1
         .Range("A1:F1").AutoFilter 3, Ary(i)
         .AutoFilter.Range.Columns(6).Copy Sheets(Ary(i)).Range("A1")
      Next i
      .Range("A1:F1").AutoFilter 3, Ary(i), xlOr, ""
      .AutoFilter.Range.Columns(6).Copy Sheets("Blank").Range("A1")
   End With
End Sub

 

[PCL]

See next code
To be launched from sheet RAMSES

Option Explicit
Sub Treat()
Dim WS  As Worksheet
Const FR   As Integer = 2
Const WSCol As String = "C"
Const WkCol As String = "F"
Const WgCode1 As String = "#N/A"
Const WgCode2 As String = ""
Const WsBlkName As String = "Blank"
Dim I  As Integer, LR  As Integer
Dim WsName As String


     LR = Cells(Rows.Count, "A").End(3).Row
     For I = FR To LR
        If (IsError(Cells(I, WSCol))) Then
            WsName = ""
        Else
            WsName = Cells(I, WSCol).Value
        End If
        If ((WsName <> WgCode1) And (WsName <> WgCode2)) Then
            If (IsSheetExists(WsName)) Then _
                Cells(I, WkCol).Copy Destination:=Sheets(WsName).Cells(Rows.Count, 1).End(3)(2)
        Else
            Cells(I, WkCol).Copy Destination:=Sheets(WsBlkName).Cells(Rows.Count, 1).End(3)(2)
        End If
     Next I
     MsgBox (" Job Done")
End Sub


Function IsSheetExists(ByVal SheetName As String) As Boolean
    On Error Resume Next
    IsSheetExists = Len(Sheets(SheetName).Name)
    On Error GoTo 0
End Function

 

[Negi1984]

Hi Fluff,

Code is working but output is not 100% correct. 1 point to note is there are no headers in RAMSES sheet. (I will create headers in it if needed).
Also if in cell C in RAMSES sheet there is not data for any sheet then its showing #REF error in respective output sheet.

Note : All cell values in column F contains formula.

Regards,
Rajender

 

[Negi1984]

Hi PCL,

When I am running the code, its showing me compile error.
Sub or function not defined.

Please suggest.

Regards,
Rajender

 

[PCL]

"Sub or function not defined." did you copy the full code included the Function one at the bottom ???
For which statement is shown such message ??

 

[Negi1984]

Hi PCL,

I just noticed. I missed to copy that function code.
I tested and tried. but its giving me #Ref error in respective sheets. My column F contains formula.


What I will do Create another macro to copy paste column F2 to last row as value in RAMSES sheet , and run your code than.
Also please suggest, if I need to show my output from column A1 than what adjustment I needed in given code(suppose in RAMSES sheet my data started from row 2)?

Regards,
Rajender

 

[PCL]

Another run

Option Explicit
Sub Treat()
Dim WS  As Worksheet
Const FR   As Integer = 2
Const WSCol As String = "C"
Const WkCol As String = "F"
Const WgCode1 As String = ""
Const WsBlkName As String = "Blank"
Dim i  As Integer, LR  As Integer
Dim WsName As String


     LR = Cells(Rows.Count, "A").End(3).Row
     For i = FR To LR
        If (IsError(Cells(i, WSCol))) Then
            WsName = ""
        Else
            WsName = Cells(i, WSCol).Value
        End If
        If (WsName <> WgCode1) Then
            If (IsSheetExists(WsName)) Then _
                Sheets(WsName).Cells(Rows.Count, 1).End(3)(2) = Cells(i, WkCol).Value
        Else
            Sheets(WsBlkName).Cells(Rows.Count, 1).End(3)(2) = Cells(i, WkCol).Value
        End If
     Next i
     MsgBox (" Job Done")
End Sub


Function IsSheetExists(ByVal SheetName As String) As Boolean
    On Error Resume Next: IsSheetExists = Len(Sheets(SheetName).Name): On Error GoTo 0
End Function

 

[Negi1984]

Hi PCL,

Thanks a lot. Code is working fine.
Have a nice day to you .

Regards,
Rajender