VBA Help Needed - Need to modify code to Copy Rows to existing Multiple worksheet based on condition and create new worksheet if one does not exist

[RPE]

Good day, I am a new member and need help with a VBA code. The code works except I will get an error when it encounters a value in the specified column “T” that does not have a matching worksheet name.

I would like to modify the code so if no tab exists with a matching value found in the column “T” then it should create a new sheet with the name, copies header and then the row to the new sheet.

Below is the macro that I am currently trying to modify, any help would be appreciated. I have also added a sample excel file.



Sub CopyDataToSheets()

Dim copyfromws As Worksheet

Dim copytows As Worksheet

Dim cfrng As Range

Dim ctrng As Range

Dim cflr As Long

Dim ctlr As Long

Dim i As Long

Dim currval As String


Set copyfromws = Sheets("Report")

cflr = copyfromws.Cells(Rows.Count, "A").End(xlUp).Row


' Copy Row of Data to Specific Worksheet based on value in Column T

' Existing Formulas in Columns F through H or J are automatically extended to the new row of data

For i = 2 To cflr

currval = copyfromws.Cells(i, 20).Value

Set copytows = Sheets(currval)

ctlr = copytows.Cells(Rows.Count, "A").End(xlUp).Row + 1

Set cfrng = copyfromws.Range("A" & i & ":Y" & i)

Set ctrng = copytows.Range("A" & ctlr & ":Y" & ctlr)

ctrng.Value = cfrng.Value

Next

End Sub

 

[DanteAmor]

Hello @RPE and welcome to forum.

Change your macro to the following. It makes the copy of all the records to the destination sheet instead of doing it one by one.

If the sheet does not exist, it also creates it.

Sub CopyDataToSheets()
  Dim sh As Worksheet
  Dim dic As Object
  Dim c As Range
  Dim ky As Variant
  Dim lr As Long, lr2 As Long
  
  Application.ScreenUpdating = False
  
  Set sh = Sheets("Report")
  Set dic = CreateObject("scripting.dictionary")
  
  If sh.AutoFilterMode Then sh.AutoFilterMode = False
  lr = sh.Range("T" & Rows.Count).End(xlUp).Row
  
  For Each c In sh.Range("T2:T" & lr)
    dic.Item(c.Value) = Empty
  Next c
  
  For Each ky In dic.Keys
    sh.Range("A1:T1").AutoFilter 20, ky
    If Evaluate("ISREF('" & ky & "'!A1)") = False Then
      Sheets.Add(, Sheets(Sheets.Count)).Name = ky
      sh.AutoFilter.Range.Range("A1:Y" & lr).Copy Range("A1")
    Else
      lr2 = Sheets(ky).Range("T" & Rows.Count).End(xlUp).Row + 1
      sh.AutoFilter.Range.Range("A2:Y" & lr).Copy Sheets(ky).Range("A" & lr2)
    End If
  Next ky
  
  sh.Select
  sh.ShowAllData
  Application.ScreenUpdating = True
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor
--------------

 

[RPE]

Hello @RPE and welcome to forum.

Change your macro to the following. It makes the copy of all the records to the destination sheet instead of doing it one by one.

If the sheet does not exist, it also creates it.

Sub CopyDataToSheets()
  Dim sh As Worksheet
  Dim dic As Object
  Dim c As Range
  Dim ky As Variant
  Dim lr As Long, lr2 As Long
 
  Application.ScreenUpdating = False
 
  Set sh = Sheets("Report")
  Set dic = CreateObject("scripting.dictionary")
 
  If sh.AutoFilterMode Then sh.AutoFilterMode = False
  lr = sh.Range("T" & Rows.Count).End(xlUp).Row
 
  For Each c In sh.Range("T2:T" & lr)
    dic.Item(c.Value) = Empty
  Next c
 
  For Each ky In dic.Keys
    sh.Range("A1:T1").AutoFilter 20, ky
    If Evaluate("ISREF('" & ky & "'!A1)") = False Then
      Sheets.Add(, Sheets(Sheets.Count)).Name = ky
      sh.AutoFilter.Range.Range("A1:Y" & lr).Copy Range("A1")
    Else
      lr2 = Sheets(ky).Range("T" & Rows.Count).End(xlUp).Row + 1
      sh.AutoFilter.Range.Range("A2:Y" & lr).Copy Sheets(ky).Range("A" & lr2)
    End If
  Next ky
 
  sh.Select
  sh.ShowAllData
  Application.ScreenUpdating = True
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor
--------------

Dante,
Wow, that work perfectly and seems to be way more efficient than the one I had created/modified. I will now test it on a report with 175,000 lines and 80 preexisting tabs. i will definitely let you know the result.

In my old code and looks like maybe yours too. We are limited to columns A:Y, can we modify so it will self adjust if a column is added or removed? So if a column is added I will not need to change from A1:Y to A1:Z?
sh.AutoFilter.Range.Range("A1:Y" & lr).Copy Range("A1")

 

[RPE]

@DanteAmor or anyone else, I am new to VBA so any help on this would be appreciated.

The VBA Code below that was provide by "DanteAmorworks" works even better than my original code except I forgot to include one more criteria to keep me from getting duplicate rows copied over as this is a 2 step process and that row may have already been copied in the first step when i ran my first macro.

I need the code to check if the value in column "T" is equal to the value in Column "AA". If true then do not copy row but if false then continue to copy the row to the tab with the matching name and if no tab exists with a matching value found in the column “T” then it should create a new sheet with the name, copies header and then the row to the new sheet.

VBA Code:

Sub CopyDataToSheets()
Dim sh As Worksheet
Dim dic As Object
Dim c As Range
Dim ky As Variant
Dim lr As Long, lr2 As Long

Application.ScreenUpdating = False

Set sh = Sheets("Report")
Set dic = CreateObject("scripting.dictionary")

If sh.AutoFilterMode Then sh.AutoFilterMode = False
lr = sh.Range("T" & Rows.Count).End(xlUp).Row

For Each c In sh.Range("T2:T" & lr)
dic.Item(c.Value) = Empty
Next c

For Each ky In dic.Keys
sh.Range("A1:T1").AutoFilter 20, ky
If Evaluate("ISREF('" & ky & "'!A1)") = False Then
Sheets.Add(, Sheets(Sheets.Count)).Name = ky
sh.AutoFilter.Range.Range("A1:Y" & lr).Copy Range("A1")
Else
lr2 = Sheets(ky).Range("T" & Rows.Count).End(xlUp).Row + 1
sh.AutoFilter.Range.Range("A2:Y" & lr).Copy Sheets(ky).Range("A" & lr2)
End If
Next ky

sh.Select
sh.ShowAllData
Application.ScreenUpdating = True
End Sub