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

New Member
Joined
Jun 17, 2020
Messages
13
Office Version
  1. 365
Platform
  1. Windows
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

1592396470583.png

1592396589617.png
 

Some videos you may like

Excel Facts

When they said...
When they said you are going to "Excel at life", they meant you "will be doing Excel your whole life".

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,618
Office Version
  1. 2007
Platform
  1. Windows
Try this

VBA Code:
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

New Member
Joined
Jun 17, 2020
Messages
13
Office Version
  1. 365
Platform
  1. Windows
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

Well-known Member
Joined
Dec 3, 2018
Messages
12,618
Office Version
  1. 2007
Platform
  1. Windows
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:

VBA 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
      .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

New Member
Joined
Jun 17, 2020
Messages
13
Office Version
  1. 365
Platform
  1. Windows
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

Well-known Member
Joined
Dec 3, 2018
Messages
12,618
Office Version
  1. 2007
Platform
  1. Windows
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.


VBA 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
 

Watch MrExcel Video

Forum statistics

Threads
1,127,183
Messages
5,623,238
Members
415,957
Latest member
Newguy1924

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
Top