# VBA Macro for copy columns by name and paste as column Name sheet



## sinoyon780 (Dec 19, 2022)

I'm a beginner in VBA, so please assist me. 
I want to copy the columns by name, like *Quality, Engineering*..... and peast to specific sheet same as cualumn name and start from maybe D1. and in summay sheet live data column will added every time as like previous column name. so please help me someone expart 🙏





*Above one is Summary shhet And data in the main sheet is updated with column entries every time.*


This for sheet as same as column name in summary sheet. >>





I appreciate your help


----------



## Flashbond (Dec 19, 2022)

Like this?

```
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim lRow As Long
  Dim summaryWS As Worksheet
  Dim WSname As String
 
  Set summaryWS = Worksheets("Summary")
  WSname = summaryWS.Cells(1, Target.Column).Value
  lRow = summaryWS.Cells(Rows.Count, 1).End(xlUp).Row
 
  Application.ScreenUpdating = False
  With Worksheets(WSname)
    For i = 1 To lRow
      .Cells(i, 1).Value = summaryWS.Cells(i, 1).Value
      .Cells(i, 2).Value = summaryWS.Cells(i, 2).Value
      .Cells(i, 3).Value = summaryWS.Cells(i, 3).Value
      .Cells(i, 4).Value = summaryWS.Cells(i, Target.Column).Value
    Next
  End With
  Application.ScreenUpdating = True
End Sub
```


----------



## Flashbond (Dec 19, 2022)

One small update:

```
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim lRow As Long
  Dim summaryWS As Worksheet
  Dim WSname As String
 
  Set summaryWS = Worksheets("Summary")
  WSname = summaryWS.Cells(1, Target.Column).Value
  lRow = summaryWS.Cells(Rows.Count, 1).End(xlUp).Row

  Application.EnableEvents = False
  Application.ScreenUpdating = False
  With Worksheets(WSname)
    For i = 1 To lRow
      .Cells(i, 1).Value = summaryWS.Cells(i, 1).Value
      .Cells(i, 2).Value = summaryWS.Cells(i, 2).Value
      .Cells(i, 3).Value = summaryWS.Cells(i, 3).Value
      .Cells(i, 4).Value = summaryWS.Cells(i, Target.Column).Value
    Next
  End With
  Application.ScreenUpdating = True
  Application.EnableEvents = True
End Sub
```


----------



## sinoyon780 (Dec 19, 2022)

Flashbond said:


> Like this?
> 
> ```
> Private Sub Worksheet_Change(ByVal Target As Range)
> ...




```
Sub CopyColumnsByName()
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim sourceRange As Range
    Dim targetRange As Range
    Dim columnName As String
    Dim uniqueNames As Collection
    
    ' Set the source worksheet
    Set sourceSheet = ThisWorkbook.Sheets("Sheet1")
    
    ' Set the range to search in the source sheet
    Set sourceRange = sourceSheet.Range("A1:Z1")
    
    ' Create a collection to store the unique column names
    Set uniqueNames = New Collection
    
    ' Loop through the columns in the source range
    For Each c In sourceRange.Columns
        columnName = c.Value
        
        If Not IsEmpty(columnName) Then
            ' If the column name is not empty, check if it is unique
            On Error Resume Next
            uniqueNames.Add columnName, CStr(columnName)
            On Error GoTo 0
        End If
    Next c
    
    ' Loop through the unique column names
    For Each n In uniqueNames
        columnName = n
        
        ' Create a new sheet with the same name as the column
        Set targetSheet = ThisWorkbook.Sheets.Add
        targetSheet.Name = columnName
        On Error Resume Next
        ' Loop through the columns in the source range
        For Each c In sourceRange.Columns
            If c.Value = columnName Then
                ' If the column name matches the current unique name, copy the column to the new sheet
                c.EntireColumn.Copy Destination:=targetSheet.Cells(1, targetSheet.Columns.Count).End(xlToLeft).Offset(0, 1)
            End If
        Next c
    Next n
    
    ' Clean up
    Set sourceSheet = Nothing
    Set targetSheet = Nothing
    Set sourceRange = Nothing
    Set targetRange = Nothing
    Set uniqueNames = Nothing
End Sub
```

Like this 👆But The codes are working fine, with one exception: if I add a new column to the current worksheet, I run the code, and it returns an error, but it should be run, and the new column should be moved to another sheet based on the column name. For example, there were previously 5 columns named "*Quality*." after run all 5 gose to 1 workshhet with name quality but when i added one new column with name quality then it's not going but it's shoud go and added with previous 5 column.
or can i fix the sheet name with column name and every time run and get all column from main sheet to Named shhet. because data in the main sheet is updated with column entries every time.


----------



## Flashbond (Dec 19, 2022)

sinoyon780 said:


> ```
> Sub CopyColumnsByName()
> Dim sourceSheet As Worksheet
> Dim targetSheet As Worksheet
> ...



I don't understand which columns you want to copy. You can change copy part as you need.

```
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim lRow As Long
  Dim summaryWS As Worksheet
  Dim WSname As String
  Dim ws as Worksheet
  Dim wsExist As Boolean

  wsExist = False
  Set summaryWS = Worksheets("Summary")
  lRow = summaryWS.Cells(Rows.Count, 1).End(xlUp).Row
  WSname = summaryWS.Cells(1, Target.Column).Value

  Application.EnableEvents = False
  If Not Intersect(Target, Rows(1)) Is Nothing And Target.Column > 3 Then
    For Each ws In ThisWorkbook.Worksheets
      If ws.Name = Target.Value Then
        wsExist = True
      End If
    Next
    If Not wsExist Then
      Sheets.Add.Name = Target.Value
      WSname = Target.Value
    End If
  End If
 
  Application.ScreenUpdating = False
  With Worksheets(WSname)
    For i = 1 To lRow
      'You can change after here as which cells you want to copy.
      .Cells(i, 1).Value = summaryWS.Cells(i, 1).Value
      .Cells(i, 2).Value = summaryWS.Cells(i, 2).Value
      .Cells(i, 3).Value = summaryWS.Cells(i, 3).Value
      .Cells(i, 4).Value = summaryWS.Cells(i, Target.Column).Value
    Next
  End With
  Application.ScreenUpdating = True
  Application.EnableEvents = True
End Sub
```


----------



## sinoyon780 (Dec 19, 2022)

Flashbond said:


> I don't understand which columns you want to copy. You can change copy part as you need.
> 
> ```
> Private Sub Worksheet_Change(ByVal Target As Range)
> ...


Like all Quality columns to Quality sheet, all Engineering columns to Engineering sheet from summary sheet and in summary sheet soemthing like live data, later will add any new columns like qualitu or engineering....


----------



## Flashbond (Dec 19, 2022)

Ohh now I see.. You have dublicates... Then:

```
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim lRow As Long
  Dim summaryWS As Worksheet
  Dim WSname As String
  Dim ws as Worksheet
  Dim wsExist As Boolean
  Dim lCol As Long
  Dim c2 As Long
 
  wsExist = False
  Set summaryWS = Worksheets("Summary")
  lRow = summaryWS.Cells(Rows.Count, 1).End(xlUp).Row
 
  WSname = summaryWS.Cells(1, Target.Column).Value
  Application.EnableEvents = False
  If Not Intersect(Target, Rows(1)) Is Nothing And Target.Column > 3 Then
    For Each ws In ThisWorkbook.Worksheets
      If ws.Name = WSname Then
        wsExist = True
      End If
    Next
    If Not wsExist Then
      Sheets.Add.Name = Target.Value
      WSname = Target.Value
    End If
  End If

  lCol = summaryWS.Cells(1, Columns.Count).End(xlToLeft).Column
  Application.ScreenUpdating = False
  With Worksheets(WSname)
     For r = 1 To lRow
       c2 = 4
       'You can change after here as which cells you want to copy.
       .Cells(r, 1).Value = summaryWS.Cells(r, 1).Value
       .Cells(r, 2).Value = summaryWS.Cells(r, 2).Value
       .Cells(r, 3).Value = summaryWS.Cells(r, 3).Value
       For c = 4 To lCol
         If summaryWS.Cells(1, c).Value = WSname Then
           .Cells(r, c2).Value = summaryWS.Cells(r, c).Value
           c2 = c2 + 1
         End If
       Next
    Next
  End With
  Application.ScreenUpdating = True
  Application.EnableEvents = True
End Sub
```


----------

