First Macro - would like it to loop through all batches.

[BigDxwg]

Hi all,
I have proudly created my first macro (albeit using the Record feature in Excel).

I have a master data with about 100,000 rows of data and about 50 columns.

The master data sheet contains account information and related owners. The objective is to split this data by batches and send out these details out. However there are around 4,000 batches, each batch can have 1 or more account. On the master I am giving them a batch no 100, 101, 102 etc.

I manually filter by batch and copy/paste relevant columns into new template, and repeat until we have created files for each of the batches. I created a macro and successfully copies/pastes into new template file and saves. However I now wish to add something to allow the batch to autoloop until all batches 1-4000 have been created and saved until there are no more matches. A simple google search has shown the code is not too long but there are so many different examples I am confused as to what would be best to use. The batch no is in Col A.

Can someone assist me with a sample code that would repeat until there are no more batches left. If my understanding is correct I would just need to add this to beginning of my existing code. Thanks in advance, any questions please ask.

 

[Fluff]

Hi & welcome to the board.
Could you please post the code you already have?
When doing so click on the # icon in the reply window & paste your code between the tags

 

[BigDxwg]

Thanks Fluff,

Sample copy of sheet below with headers for your outstanding. Each account has a few different sources for owners, and we gave grouped by batch (ColA) For each owner we are sending them out a sheet of their accounts to validate. There are about 400 batches. We can manually create a batch using my below macro however would be great if I can get assistance in adding macro to automate.

So filter by batch number, run macro, repeat for each batch. Ignore blanks.

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Batch

ID

AccountName

SystemName

Platform

Loc

AcctDesc

Owner 1

Owner 2

Owner 3

<tbody>
</tbody><colgroup><col><col><col><col><col span="12"></colgroup>

Sub CreateTemp()
'
' Full Working Version 1
'
'
    Workbooks.Open filename:= _
        "C:\Temp\Batch 5 sheets to send\Account Validation Template.xlsx"
    Application.WindowState = xlNormal
    Application.Left = -1005.5
    Application.Top = 361.75
    Application.WindowState = xlMaximized
    ActiveWindow.SmallScroll Down:=15
    Sheets("Information Capture Sheet").Select
    Windows("cut of master 1310 with flags.xlsm").Activate
    Range("B3:D3").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Windows("Account Validation Template.xlsx").Activate
    Range("A2").Select
    ActiveSheet.Paste
    Windows("cut of master 1310 with flags.xlsm").Activate
    Range("K3").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range("K3:M3").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Account Validation Template.xlsx").Activate
    Range("J2").Select
    ActiveSheet.Paste
    Range("A2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range("A2:L2").Select
    Selection.Copy
    Range(Selection, Selection.End(xlDown)).Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Selection.End(xlUp).Select
    Range("A2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range("A2:L2").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range(Selection, Selection.End(xlDown)).Select
    Selection.PasteSpecial Paste:=xlPasteValidation, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("A2").Select
    Windows("cut of master 1310 with flags.xlsm").Activate
    Range("A2").Select
    Selection.End(xlDown).Select
    Selection.Copy
    Windows("Account Validation Template").Activate
    Sheets("Guidelines").Select
'    ActiveWindow.SmallScroll Down:=-39
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With Selection.Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    Dim filename As String
    filename = Range("A1")
    ActiveWorkbook.SaveAs filename:= _
        "C:\Temp\Batch 5 sheets to send\Account Validation - " & filename & ".xlsx" _
        , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
End Sub

 

[Fluff]

Thanks for the code.
I had misunderstood your OP, but have initially slimmed down your macro.

Sub CreateTemp()

    Dim Wbk As Workbook
    Dim SrcSht As Worksheet
    Dim Destsht As Worksheet
    Dim UsdRws As Long
    Dim Fname As String

    Set Wbk = Workbooks.Open("C:\Temp\Batch 5 sheets to send\Account Validation Template.xlsx")
    Set Destsht = Sheets("Information Capture Sheet")
    Set SrcSht = Workbooks("cut of master 1310 with flags.xlsm").Sheets("Records")
    UsdRws = SrcSht.Cells.Find("*", After:=SrcSht.Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    SrcSht.Range("B3:D" & UsdRws).Copy Destsht.Range("A2")
    SrcSht.Range("K3:M" & UsdRws).Copy Destsht.Range("J2")
    Destsht.Range("A2:L" & UsdRws).Copy
    Destsht.Range("A2").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Destsht.Range("A2").PasteSpecial Paste:=xlPasteValidation, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    SrcSht.Range("A2:A" & UsdRws).Copy Wbk.Sheets("Guidelines").Range("A1")
    With Wbk.Sheets("Guidelines").Range("A1:A" & UsdRws)
        With .Interior
            .Pattern = xlNone
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        With .Font
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = 0
        End With
        Fname = .Range("A1")
    End With
   Wbk.SaveAS filename:= _
        "C:\Temp\Batch 5 sheets to send\Account Validation - " & Fname & ".xlsx" _
        , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
End Sub

If you can check that this works on your data, I can then add the extras to loop through your data.

 

[BigDxwg]

Thanks fluff - that certainly looks neater
However there are a couple of issues.
1 - It doesn't seem to be copy/pasting format/validation on destination sheet
2 - The save file name don't work. Its picking the column header that is in A2. The filename was previously picked from the last value in column A. (or can be whatever the first value is below A2)

 

[Fluff]

Would you be willing, to share your workbook via Ondrive , dropbox, or googledrive?
As it works on my test data, but obviously not on yours.

 

[BigDxwg]

As I am working with work data, I would be reluctant to share. Even if I were to strip out confidential stuff and change column headings, I have known people to be shot for sharing for similar stuff Sorry about that. I got the file save working, however I can seem to see why the copy/paste formats and validation aint working as there is nothing wrong with the code.

I found this thread:
https://www.mrexcel.com/forum/excel...o-goes-through-filtered-list.html#post2061970

I did copy this code to beginning of my code it is now doing what I want to. I would so love to use your code to drive my macro as the OCD in prefers the tidier code, but just figure out why copy/paste format/validations aint working.

Thank you for your time, if you have any suggestions I'd welcome them. MAybe it be worth me pasting the complete code with loop so see if it can be tidied up?

 

[BigDxwg]

Here is the code, albeit in a messy state:

Sub CreatewithLoops()
'
' Full Working Version 1
'
' 
Dim rngCELL As Range
    Dim rngSEARCHAREA As Range
    Dim dic As Scripting.Dictionary
    Dim dicITEM As Variant
 
    '// change to fit your filter range (excluding column label)
    Set rngSEARCHAREA = ActiveSheet.Range("A2:A10736")
 
    If rngSEARCHAREA Is Nothing Then GoTo Finish
 
    Set dic = New Scripting.Dictionary
    For Each rngCELL In rngSEARCHAREA
        If Not dic.Exists(rngCELL.Value) And Not rngCELL.Value = vbNullString Then
            dic.Add rngCELL.Value, rngCELL.Value
        End If
    Next
 
    If Not dic Is Nothing Then
        For Each dicITEM In dic.Items
            With rngSEARCHAREA.Offset(-1).Resize(rngSEARCHAREA.Rows.Count + 1)
                .AutoFilter field:=1, Criteria1:=dicITEM
                '// do whatever it is that you want to do _
                    in this example I'm copying each filtered table to sheet2 _
                    and to the next available blank row
                '.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Copy
                                     ' ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
                '.AutoFilter field:=1

    Workbooks.Open filename:= _
        "C:\Temp\Batch 5 sheets to send\Account Validation Template.xlsx"
    Application.WindowState = xlNormal
    Application.Left = -1005.5
    Application.Top = 361.75
    Application.WindowState = xlMaximized
    ActiveWindow.SmallScroll Down:=15
    Sheets("Information Capture Sheet").Select
    Windows("cut of master 1310 with flags.xlsm").Activate
    Range("B3:D3").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Windows("Account Validation Template.xlsx").Activate
    Range("A2").Select
    ActiveSheet.Paste
    Windows("cut of master 1310 with flags.xlsm").Activate
    Range("K3").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range("K3:M3").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Account Validation Template.xlsx").Activate
    Range("J2").Select
    ActiveSheet.Paste
    Range("A2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range("A2:L2").Select
    Selection.Copy
    Range(Selection, Selection.End(xlDown)).Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Selection.End(xlUp).Select
    Range("A2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range("A2:L2").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range(Selection, Selection.End(xlDown)).Select
    Selection.PasteSpecial Paste:=xlPasteValidation, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("A2").Select
    Windows("cut of master 1310 with flags.xlsm").Activate
    Range("A2").Select
    Selection.End(xlDown).Select
    Selection.Copy
    Windows("Account Validation Template").Activate
    Sheets("Guidelines").Select
'    ActiveWindow.SmallScroll Down:=-39
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With Selection.Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    Dim filename As String
    filename = Range("A1")
    ActiveWorkbook.SaveAs filename:= _
        "C:\Temp\Batch 5 sheets to send\Account Validation - " & filename & ".xlsx" _
        , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
Finish:
    Set rngSEARCHAREA = Nothing
    Set dic = Nothing

End Sub

 

[Fluff]

I fully understand, why you don't want to share your files.
But If the code you have pasted in post#8 is working. It's probably best if I leave alone, incase I mess it up.

 

[BigDxwg]

Thanks for your help anyhow mate. It was interesting to see how you simplified my code. It was great for my learning curve
Have a good day.