Hi Everybody,I am trying to sort this excel file.What I am trying to do is this:In the TYPE column of LR Listing, copy the whole line to another sheet with the same name(s).If I update or add to LR Listing, it automatically updates the other sheets.What I have tried:I created a macro. I got it to sort one thing, but if I add more than one it will sort the first thing and then nothing for the others.I created another macro to run the macro upon opening of the file (which is ok to meet #2 above), but I cannot figure out how to run multiple macros upon opening of the file.I put the macros I tried into sheets called MACRO 1 and MACRO 2 Thanks in advanced Alan

copy data to another sheet | Microsoft Community Hub

Dim wsData As Worksheet Sub CopyData() Dim wsDest As Worksheet Dim shName As String Dim lr As Long Dim lc As Long Dim dlr As Long Dim Rng As Range Dim Cel As Range Application.ScreenUpdating = False Set wsData = Worksheets("LR Listing") lr = wsData.Cells(Rows.Count, "C").End(xlUp).Row lc = wsData.UsedRange.Columns.Count Set Rng = wsData.Range("C2:C" & lr) For Each Cel In Rng If Cel.Value <> "" Then shName = Cel.Value shName = Replace(Replace(Replace(Replace(Replace(Replace(Replace(shName, ":", ""), "/", ""), "\", ""), "?", ""), "*", ""), "[", ""), "]", "") On Error Resume Next Set wsDest = Worksheets(shName) On Error GoTo 0 If wsDest Is Nothing Then Set wsDest = Worksheets.Add(After:=Worksheets(Worksheets.Count)) wsDest.Name = shName End If dlr = wsDest.Cells(Rows.Count, "C").End(xlUp).Row + 1 wsData.Range(wsData.Cells(Cel.Row, 1), wsData.Cells(Cel.Row, lc)).Copy wsDest.Range("A" & dlr) End If Set wsDest = Nothing Next Cel Call SortSheetTabs wsData.Activate Application.ScreenUpdating = True End Sub Sub SortSheetTabs() Dim i As Integer, j As Integer For i = 2 To Worksheets.Count For j = 2 To Worksheets.Count - 1 If Worksheets(j).Name > Worksheets(j + 1).Name Then Worksheets(j).Move After:=Worksheets(j + 1) End If Next j Next i End Sub

5 Replies

Subodh_Tiwari_sktneer

Silver Contributor

Oct 28, 2020

typhoon1911

Instead of creating one macro for each type available in column C, you may try something like below. Place this macro on a Standard Module like Module1 and then if you want this macro to run when the file is opened, call this macro within Workbook_Open event on ThisWorkbook Module.

Sub CopyData()
Dim wsData      As Worksheet
Dim wsDest      As Worksheet
Dim shName      As String
Dim lr          As Long
Dim lc          As Long
Dim dlr         As Long
Dim Rng         As Range
Dim Cel         As Range

Application.ScreenUpdating = False

Set wsData = Worksheets("LR Listing")
lr = wsData.Cells(Rows.Count, "C").End(xlUp).Row
lc = wsData.UsedRange.Columns.Count

Set Rng = wsData.Range("C2:C" & lr)

For Each Cel In Rng
    If Cel.Value <> "" Then
        shName = Cel.Value
        shName = Replace(Replace(Replace(Replace(Replace(Replace(Replace(shName, ":", ""), "/", ""), "\", ""), "?", ""), "*", ""), "[", ""), "]", "")
        On Error Resume Next
        Set wsDest = Worksheets(shName)
        On Error GoTo 0
        If wsDest Is Nothing Then
            Set wsDest = Worksheets.Add(after:=Worksheets(Worksheets.Count))
            wsDest.Name = shName
        End If
        dlr = wsDest.Cells(Rows.Count, "C").End(xlUp).Row + 1
        wsData.Range(wsData.Cells(Cel.Row, 1), wsData.Cells(Cel.Row, lc)).Copy wsDest.Range("A" & dlr)
    End If
    Set wsDest = Nothing
Next Cel

Application.ScreenUpdating = True
End Sub

Private Sub Workbook_Open()
    Call CopyData
End Sub

typhoon1911

Copper Contributor

Oct 28, 2020

Subodh_Tiwari_sktneer Thanks for the quick reply.

The majority of it works, but it does not sort FuseSaver, IntelliRupter, and IntelliRupter LS.

Does the name have to match exactly?

Alan

Subodh_Tiwari_sktneer

Silver Contributor

Oct 28, 2020

typhoon1911

By sorting if you mean sorting the Sheet Tabs, you may replace the existing code with the following one...

Dim wsData      As Worksheet

Sub CopyData()
Dim wsDest      As Worksheet
Dim shName      As String
Dim lr          As Long
Dim lc          As Long
Dim dlr         As Long
Dim Rng         As Range
Dim Cel         As Range

Application.ScreenUpdating = False

Set wsData = Worksheets("LR Listing")
lr = wsData.Cells(Rows.Count, "C").End(xlUp).Row
lc = wsData.UsedRange.Columns.Count

Set Rng = wsData.Range("C2:C" & lr)

For Each Cel In Rng
    If Cel.Value <> "" Then
        shName = Cel.Value
        shName = Replace(Replace(Replace(Replace(Replace(Replace(Replace(shName, ":", ""), "/", ""), "\", ""), "?", ""), "*", ""), "[", ""), "]", "")
        On Error Resume Next
        Set wsDest = Worksheets(shName)
        On Error GoTo 0
        If wsDest Is Nothing Then
            Set wsDest = Worksheets.Add(After:=Worksheets(Worksheets.Count))
            wsDest.Name = shName
        End If
        dlr = wsDest.Cells(Rows.Count, "C").End(xlUp).Row + 1
        wsData.Range(wsData.Cells(Cel.Row, 1), wsData.Cells(Cel.Row, lc)).Copy wsDest.Range("A" & dlr)
    End If
    Set wsDest = Nothing
Next Cel
Call SortSheetTabs
wsData.Activate
Application.ScreenUpdating = True
End Sub

Sub SortSheetTabs()
Dim i As Integer, j As Integer

For i = 2 To Worksheets.Count
    For j = 2 To Worksheets.Count - 1
          If Worksheets(j).Name > Worksheets(j + 1).Name Then
             Worksheets(j).Move After:=Worksheets(j + 1)
          End If
    Next j
Next i

End Sub

The code will replace any invalid character which is not allowed in Sheet Name and replace it with nothing.

What you can do here is, delete all the Sheets except the LR Listing and run the macro which will insert all the tabs with relevant data and sort them in ascending order.

Forum Discussion

copy data to another sheet

5 Replies

Resources