Macro Button To create workbook base on settings

[pizpower]

Hi,

I would like to know how to generate a new workbook based on a cell value, for example:

Sheet1

ID	AccID	bla	Generate?
bla12	bla123	123	No
bla1222	sfsd12	123123	Yes
asda	523erdf	ed232r	No
1234234	asdad23	24wrfsd	Yes

Sheet2

Generate Button Here

Saving Path Here, Example: C:\Desktop

If Generate is Yes, I would like to generate the new workbook with Headers from Sheet1 (From B1 to C1), the lines that are marked with generate yes only the folder to be saved base on the above cell setting, filename needs to be List_Date_Time.xls

Generate xls file:

AccID	bla
sfsd12	123123

asdad23

24wrfsd

Is it possible?

Thanks.

 

[Jeffrey Mahoney]

How about this?

I didn't know what "List" was for the filename

Sub GenerateWB()
  Dim Cel As Range
  Dim CC As Range
  Dim Rng As Range
  Dim CopyRng As Range
  Dim OutRng As Range
  Dim ListStr As String
  Dim Path As String
  Dim FileName As String
  Dim PathName As String
  Dim TWB As Workbook
  Dim NWB As Workbook
  Dim Sht1 As Worksheet
  Dim Sht2 As Worksheet
  Dim NSht As Worksheet
  
  Set TWB = ThisWorkbook
  Set Sht1 = Sheets("Sheet1")
  Set Sht2 = Sheets("Sheet2")
  
  Path = Sht2.Range("B1").Value
  If Right(Path, 1) <> "\" Then Path = Path & "\"
  
  ListStr = "WhatIsThis"
  
  Set Cel = Sht1.Range("A2")
  Set Rng = Sht1.Range(Cel, Cel.Offset(1000000, 0).End(xlUp))
  
  For Each Cel In Rng
    If Cel.Offset(0, 3).Value = "Yes" Then
      If NWB Is Nothing Then
        Set NWB = Application.Workbooks.Add
        Set NSht = ActiveSheet
        Sht1.Range("B1:C1").Copy NSht.Range("A1:B1")
      End If
      Set CC = NSht.Range("A1000000").End(xlUp).Offset(1, 0)
      Set OutRng = NSht.Range(CC, CC.Offset(0, 1))
      Set CopyRng = Sht1.Range(Cel.Offset(0, 1), Cel.Offset(0, 2))
      OutRng.Value = CopyRng.Value
    End If
  Next Cel
  
  If Not NWB Is Nothing Then
    FileName = ListStr & " " & Format(Int(Now()), "mm_dd_yyyy") & " " & Format(Now() - Int(Now()), "hh_mm_ss")
    PathName = Path & FileName
    NWB.SaveAs PathName
    NWB.Close
  End If
  
  
  
End Sub

 

[pizpower]

Looks like it did the trick :D

is it possible that for the: Set Rng = Sht1.Range(Cel, Cel.Offset(1000000, 0).End(xlUp)) & Set CC = NSht.Range("A1000000").End(xlUp).Offset(1, 0) to be unlimited?

 

[pizpower]

Also just to confirm that am doing the right changes in it..

in order to increase the columns for the generate.. i need to do these changes, right? (to increase 1 more column)

From: If Cel.Offset(0, 3).Value = "Yes" Then
To: If Cel.Offset(0, 4).Value = "Yes" Then

From: Sht1.Range("B1:C1").Copy NSht.Range("A1:B1")
To: Sht1.Range("B1:D1").Copy NSht.Range("A1:B1")

From: Set OutRng = NSht.Range(CC, CC.Offset(0, 1))
To: Set OutRng = NSht.Range(CC, CC.Offset(0, 2))

From: Set CopyRng = Sht1.Range(Cel.Offset(0, 1), Cel.Offset(0, 2))
To: Set CopyRng = Sht1.Range(Cel.Offset(0, 1), Cel.Offset(0, 3))

right?

Is there any other flexible way?

Thanks.

 

[Jeffrey Mahoney]

is it possible that for the: Set Rng = Sht1.Range(Cel, Cel.Offset(1000000, 0).End(xlUp)) & Set CC = NSht.Range("A1000000").End(xlUp).Offset(1, 0) to be unlimited?

I changed the code accordingly

Is there any other flexible way?

Yes. I gave you two examples. One is to have to change it in the code every time you add columns, or created a named range. To create the named for this example (Set CopyCols = .Range("CopyCols")) just select the entire two columns you want to copy and Formulas > Name Manager > New. Now when you add or subtract columns, the macro will still work

Sub GenerateWB()
  Dim Cel As Range
  Dim CC As Range
  Dim Rng As Range
  Dim CopyRng As Range
  Dim OutRng As Range
  Dim ListStr As String
  Dim Path As String
  Dim FileName As String
  Dim PathName As String
  Dim TWB As Workbook
  Dim NWB As Workbook
  Dim Sht1 As Worksheet
  Dim Sht2 As Worksheet
  Dim NSht As Worksheet
  Dim YesCol As Range
  Dim CopyCols As Range
  
  Set TWB = ThisWorkbook
  Set Sht1 = Sheets("Sheet1")
  Set Sht2 = Sheets("Sheet2")
  
  Path = Sht2.Range("B1").Value
  If Right(Path, 1) <> "\" Then Path = Path & "\"
  
  ListStr = "WhatIsThis"
  
  With Sht1
    Set Cel = .Range("A2")
    Set Rng = .Range(Cel, .Cells(.Cells.Rows.Count, 1).End(xlUp))
    Set YesCol = .Range("D:D")                                    'Manual change here in the Macro
    Set CopyCols = .Range("CopyCols")                             'Named range from the sheet - better
  End With
  
  
  For Each Cel In Rng
    If Intersect(Cel.EntireRow, YesCol).Value = "Yes" Then
      If NWB Is Nothing Then
        Set NWB = Application.Workbooks.Add
        Set NSht = ActiveSheet
        Intersect(Sht1.Range("1:1"), CopyCols).Copy NSht.Range("A1:B1")     'Using named range
      End If
      With NSht
        Set CC = .Cells(.Cells.Rows.Count, 1).End(xlUp).Offset(1, 0)                'Unlimited
      End With
      Set OutRng = NSht.Range(CC, CC.Offset(0, 1))
      Set CopyRng = Intersect(Cel.EntireRow, CopyCols)
      OutRng.Value = CopyRng.Value
    End If
  Next Cel
  
  If Not NWB Is Nothing Then
    FileName = ListStr & " " & Format(Int(Now()), "mm_dd_yyyy") & " " & Format(Now() - Int(Now()), "hh_mm_ss")
    PathName = Path & FileName
    NWB.SaveAs PathName
    NWB.Close
  End If
    
End Sub

 

[Jeffrey Mahoney]

Please test the code before using on real data