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

sinoyon780

sinoyon780

New Member
Joined
Dec 12, 2022
Messages
21
Office Version
  1. 365
  2. 2019
  3. 2016
Platform
  1. Windows
  2. MacOS
  3. Mobile
  4. Web
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 🙏
Annotation 2022-12-19 135027.png


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. >>
Annotation 2022-12-19 1350273.png




I appreciate your help
 

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying
Sort by date Sort by votes
Like this?
VBA Code: 
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
 
Last edited by a moderator:
Upvote 0
One small update:
VBA Code: 
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
 
Upvote 0
Flashbond said:
Like this?
VBA Code: 
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
Click to expand...
VBA Code: 
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.
 
Upvote 0
sinoyon780 said:
VBA Code: 
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.
Click to expand...

I don't understand which columns you want to copy. You can change copy part as you need.
VBA Code: 
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
 
Upvote 0
Flashbond said:
I don't understand which columns you want to copy. You can change copy part as you need.
VBA Code: 
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 = WSname 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
Click to expand...
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....
 
Upvote 0
Ohh now I see.. You have dublicates... Then:
VBA Code: 
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
 
Upvote 0
Solution
You must log in or register to reply here.

Similar threads

H
  • Solved
How to copy data from one file and paste it into a dynamically named workbook
Replies
3
Views
237
dermie_72
D
T
  • Solved
VBA code cannot find sheet name
2
Replies
11
Views
254
jolivanes
jolivanes
L
  • Solved
VBA to Copy Column based on Header Name from cell Value on another Sheet
Replies
2
Views
382
lamarh755
L
S
  • Question
saving as pdf with changing additional sheet name
Replies
1
Views
80
John_w
J
P
  • Question
Automating copying of columns within same sheet in excel using VBA.
Replies
1
Views
195
MountainFog
M

Forum statistics

Threads
1,215,606
Messages
6,125,805
Members
449,262
Latest member
hideto94

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top