VBA: Copy cells in Column AH2:AM2 if value in cell AE2 is equal to sheetname, and paste to the matching sheet A21:F21 as values

[Konigsfeldt]

Hi all,

New here - tried to look for a solution but decided to post.

I have the following code, in which I want to either add more to or make a new macro.
This code creates sheets and name them after account numbers, based on a template sheet.

Either in this code, or in another code, I want the values for all rows in column AH:AM in sheet "ReconciledData" that matches the sheet name to be pasted into A21:F21 and downwards. Number of rows can vary from a few to hundreds.

I hope it makes sense, please let me know if I should elaborate further.

Thanks for any feedback.

Sub CreateSheetsFromReconcilidation()
' Example Add Worksheets with Unique Names
Dim MyRange As Range
Dim dic As Object, c As Range
Dim k As Variant, tmp As String
Set dic = CreateObject("scripting.dictionary")
Set MyRange = Sheets("ReconciledData").Range("AE2")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
Sheets("Template").Visible = True

For Each c In MyRange
tmp = Trim(c.Value)
If Len(tmp) > 0 Then dic(tmp) = dic(tmp) + 1
Next c

For Each k In dic.keys
If Not WorksheetExists(k) Then
Sheets("Template").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = k ' renames the new worksheet
ActiveSheet.[B11] = ActiveSheet.Name
End If
Next k

Sheets("Template").Visible = False

Call WorksheetsSortAscending

End Sub

 

[DanteAmor]

Try this

Sub CreateSheetsFromReconcilidation()
  Dim a As Variant, i As Long, lr As Long
  Dim dic As Object, ky As Variant, sht As Worksheet
  
  Application.ScreenUpdating = False
  Set dic = CreateObject("scripting.dictionary")
  Set sht = Sheets("Template")
  sht.Visible = True
  
  With Sheets("ReconciledData")
    If .AutoFilterMode Then .AutoFilterMode = False
    lr = .Range("AE" & Rows.Count).End(3).Row
    a = .Range("AE2:AE" & lr).Value2
    
    For i = 1 To UBound(a)
      If a(i, 1) <> "" Then dic(a(i, 1)) = Empty
    Next i
  
    For Each ky In dic.Keys
      If Not Evaluate("ISREF('" & ky & "'!A1)") Then
        sht.Copy After:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = ky 'renames the new worksheet
        Sheets(CStr(ky)).[B11] = ky
      End If
      .Range("AE1:AE" & lr).AutoFilter 1, ky
      .AutoFilter.Range.Offset(1, 3).Resize(lr, 6).Copy Sheets(CStr(ky)).Range("A21")
    Next ky
    .Select
    .Range("AE1").AutoFilter
  End With
  
  sht.Visible = False
  Application.ScreenUpdating = True
  'Call WorksheetsSortAscending
End Sub

 

[Konigsfeldt]

Fantastic, thanks a lot!!

I did nok work as a combined code though (not sure if that was planned either), but as a separate code after I ran the original code. Is some of it redundant then/should be removed? (not sure if it matters). I just want to keep the part that copy the rows.

Question: Is it possible to paste as values so the original formatting from the template is kept?

 

[DanteAmor]

I did nok work as a combined code though

You must replace your code with my code.

Is it possible to paste as values

To paste values try the following:

Sub CreateSheets_2()
  Dim a As Variant, i As Long, lr As Long
  Dim dic As Object, ky As Variant, sht As Worksheet
  
  Application.ScreenUpdating = False
  Set dic = CreateObject("scripting.dictionary")
  Set sht = Sheets("Template")
  sht.Visible = True
  
  With Sheets("ReconciledData")
    If .AutoFilterMode Then .AutoFilterMode = False
    lr = .Range("AE" & Rows.Count).End(3).Row
    a = .Range("AE2:AE" & lr).Value2
    
    For i = 1 To UBound(a)
      If a(i, 1) <> "" Then dic(a(i, 1)) = Empty
    Next i
  
    For Each ky In dic.Keys
      If Not Evaluate("ISREF('" & ky & "'!A1)") Then
        sht.Copy After:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = ky 'renames the new worksheet
        Sheets(CStr(ky)).[B11] = ky
      End If
      .Range("AE1:AE" & lr).AutoFilter 1, ky
      .AutoFilter.Range.Offset(1, 3).Resize(lr, 6).Copy
      Sheets(CStr(ky)).Range("A21").PasteSpecial xlPasteValues
    Next ky
    .Select
    .Range("AE1").AutoFilter
  End With
  
  sht.Visible = False
  Application.ScreenUpdating = True
  'Call WorksheetsSortAscending
End Sub

 

[Konigsfeldt]

Thanks, perfect.

I figured what suits my needs best is, if my code and your code are separate - so I have both, should yours be reduced then? Because all the sheet-creating and naming works fine from my code..

Also, last thing, after it paste the values, I want it to select A1 in each sheet, but when I add Range("A1").Select, it's not doing that but keeps the marker on the pasted area.

 

[DanteAmor]

I figured what suits my needs best is, if my code and your code are separate

I do not know what you mean.

Because all the sheet-creating and naming works fine from my code..

What is the problem in my code to create sheets?

______________________________________________________________________________________
I have made all the changes that you have requested. Here I also add the lines to select cell A1, but if my code doesn't work for you then you can still use your code.

Sub CreateSheets_2()
  Dim a As Variant, i As Long, lr As Long
  Dim dic As Object, ky As Variant, sht As Worksheet
  
  Application.ScreenUpdating = False
  Set dic = CreateObject("scripting.dictionary")
  Set sht = Sheets("Template")
  sht.Visible = True
  
  With Sheets("ReconciledData")
    If .AutoFilterMode Then .AutoFilterMode = False
    lr = .Range("AE" & Rows.Count).End(3).Row
    a = .Range("AE2:AE" & lr).Value2
    
    For i = 1 To UBound(a)
      If a(i, 1) <> "" Then dic(a(i, 1)) = Empty
    Next i
  
    For Each ky In dic.Keys
      If Not Evaluate("ISREF('" & ky & "'!A1)") Then
        sht.Copy After:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = ky 'renames the new worksheet
        Sheets(CStr(ky)).[B11] = ky
      End If
      Sheets(CStr(ky)).Select
      Range("A1").Select
      .Range("AE1:AE" & lr).AutoFilter 1, ky
      .AutoFilter.Range.Offset(1, 3).Resize(lr, 6).Copy
      Sheets(CStr(ky)).Range("A21").PasteSpecial xlPasteValues
    Next ky
    .Select
    .Range("AE1").AutoFilter
  End With
  
  sht.Visible = False
  Application.ScreenUpdating = True
  'Call WorksheetsSortAscending
End Sub