Macro to export text file based on worksheet parameters

[PIERANDPORT]

Hi Macro Experts!!!

I need help creating a macro that will save a range (F#:DD#) based on the supplier value in column C as a text file. I included a screenshot of what my spreadsheet set up looks like.

I need a separate text file for each supplier (Column C) that contains all of the data for that row in columns F through DD (note, some cells in this range will be blank).

Some suppliers will only have 1 line (ex. Supplier C & D) other suppliers will have multiple lines (ex. Supplier A & B).

The Headers (*Type, Description, Line Type, etc.) in F1:DD1 must be first on each text file.

I would like the name of each text file to be the supplier name (Column C).

When I import information into the spreadsheet does it need to be in alphabetical order by supplier or can it be in any order? I can do either just wasn't sure if that matters.

 

[dmt32]

Hi,
welcome to forum

Copy the code in this thread create sheets based on column and copy data without repeating
#Post 4 to a standard module

Update following lines in code

'your master sheet
    Set wsData = ThisWorkbook.Worksheets("Sheet1")
   
'Column you are filtering
    FilterCol = "B"

change the sheet name with your data & column you want to filter shown in BOLD.

and see if this code will do what you want

Dave

 

[PIERANDPORT]

Hi,
welcome to forum

Copy the code in this thread create sheets based on column and copy data without repeating
#Post 4 to a standard module

Update following lines in code

'your master sheet
    Set wsData = ThisWorkbook.Worksheets("Sheet1")
  
'Column you are filtering
    FilterCol = "B"

change the sheet name with your data & column you want to filter shown in BOLD.

and see if this code will do what you want

Dave

Hi Dave -

Thank you for the code that helps me get started.

Is it possible to adjust this code to only have the content in cells F:DD on Sheet 1 be returned in A1 of the new worksheets that are created? I would still need the column headers to be included and the worksheet name to be the Supplier Name (Column C).

Is there a macro that I can use to export each worksheet then to a txt file and saved as the worksheet name?

Thank you,
Taya

 

[dmt32]

Hi Dave -

Thank you for the code that helps me get started.

Is it possible to adjust this code to only have the content in cells F:DD on Sheet 1 be returned in A1 of the new worksheets that are created? I would still need the column headers to be included and the worksheet name to be the Supplier Name (Column C).

Thank you,
Taya

Hi
Try this update to the code

Delete existing code & Copy BOTH codes to a standard module

Option Explicit
Sub FilterColumn()
    'dmt32 aug 2020
    Dim wsData As Worksheet, wsNames As Worksheet, wsFilter As Worksheet
    Dim Datarng As Range, FilterRange As Range
    Dim rowcount As Long
    Dim FilterCol As Variant
    Dim SheetName As String
  
    On Error GoTo progend
'your master sheet
    Set wsData = ThisWorkbook.Worksheets("Sheet1")
  
'Column you are filtering
    FilterCol = "C"
  
    With Application
        .ScreenUpdating = False: .DisplayAlerts = False
    End With
'add filter sheet
    Set wsFilter = ThisWorkbook.Worksheets.Add
  
    With wsData
        .Activate
'add password if needed
        .Unprotect Password:=""
      
        Set Datarng = .Range("A1").CurrentRegion
      
'extract values from FilterCol'to filter sheet
        .Cells(1, FilterCol).Resize(Datarng.Rows.Count).AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=wsFilter.Range("A1"), Unique:=True
      
        rowcount = wsFilter.Cells(wsFilter.Rows.Count, "A").End(xlUp).Row
'set Criteria
        wsFilter.Range("B1").Value = wsFilter.Range("A1").Value
      
        For Each FilterRange In wsFilter.Range("A2:A" & rowcount)
            SheetName = CStr(Left(FilterRange.Text, 31))
'check for blank cell in range
            If SheetName <> "" Then
'add the FilterRange to criteria
'exact matches only
                wsFilter.Range("B2").Formula = "=" & """=" & SheetName & """"
'check if sheet exists
                If Not Evaluate("ISREF('" & SheetName & "'!A1)") Then
'add new sheet
                AddSheet Datarng, SheetName
                End If
'set object variable to sheet
                Set wsNames = Worksheets(SheetName)
'clear sheet
                wsNames.UsedRange.Offset(1).Clear
'copy data
                Datarng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsFilter.Range("B1:B2"), _
                CopyToRange:=wsNames.Range("A1:CY1"), Unique:=False
            End If
'clear from memory
            Set wsNames = Nothing
'clear clipboard
            Application.CutCopyMode = False
        Next
        .Select
    End With
  
progend:
    If Not wsFilter Is Nothing Then wsFilter.Delete
    With Application
        .ScreenUpdating = True: .DisplayAlerts = True
    End With
  
    If Err <> 0 Then MsgBox (Error(Err)), vbCritical, "Error"
      
End Sub

Sub AddSheet(ByVal HeadRange As Range, ByVal SheetName As String)
'resize header range to copy
    Set HeadRange = HeadRange.Rows(1).Offset(, 5).Resize(, 103)
'add new sheet
    Worksheets.Add(After:=Sheets(Sheets.Count)).Name = SheetName
'copy headers
   HeadRange.Copy
'apply formats
   With ActiveSheet.Rows(1)
    .PasteSpecial xlPasteValues
    .PasteSpecial xlPasteFormats
    .PasteSpecial xlPasteColumnWidths
   End With
'clear clipboard
   Application.CutCopyMode = False
End Sub

I have created a separate code to add new sheets - it looks busy but this is only because of applying formatting to match master sheet - if you only need to copy values then code can be reduced a little.

You will need to delete any existing sheets created by the previous code to ensure correct data is filtered to sheets.

With regards to your last question - as this is a new requirement I suggest start another thread.

Hope Helpful

Dave

 

[PIERANDPORT]

Hi
Try this update to the code

Delete existing code & Copy BOTH codes to a standard module

Option Explicit
Sub FilterColumn()
    'dmt32 aug 2020
    Dim wsData As Worksheet, wsNames As Worksheet, wsFilter As Worksheet
    Dim Datarng As Range, FilterRange As Range
    Dim rowcount As Long
    Dim FilterCol As Variant
    Dim SheetName As String
 
    On Error GoTo progend
'your master sheet
    Set wsData = ThisWorkbook.Worksheets("Sheet1")
 
'Column you are filtering
    FilterCol = "C"
 
    With Application
        .ScreenUpdating = False: .DisplayAlerts = False
    End With
'add filter sheet
    Set wsFilter = ThisWorkbook.Worksheets.Add
 
    With wsData
        .Activate
'add password if needed
        .Unprotect Password:=""
     
        Set Datarng = .Range("A1").CurrentRegion
     
'extract values from FilterCol'to filter sheet
        .Cells(1, FilterCol).Resize(Datarng.Rows.Count).AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=wsFilter.Range("A1"), Unique:=True
     
        rowcount = wsFilter.Cells(wsFilter.Rows.Count, "A").End(xlUp).Row
'set Criteria
        wsFilter.Range("B1").Value = wsFilter.Range("A1").Value
     
        For Each FilterRange In wsFilter.Range("A2:A" & rowcount)
            SheetName = CStr(Left(FilterRange.Text, 31))
'check for blank cell in range
            If SheetName <> "" Then
'add the FilterRange to criteria
'exact matches only
                wsFilter.Range("B2").Formula = "=" & """=" & SheetName & """"
'check if sheet exists
                If Not Evaluate("ISREF('" & SheetName & "'!A1)") Then
'add new sheet
                AddSheet Datarng, SheetName
                End If
'set object variable to sheet
                Set wsNames = Worksheets(SheetName)
'clear sheet
                wsNames.UsedRange.Offset(1).Clear
'copy data
                Datarng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsFilter.Range("B1:B2"), _
                CopyToRange:=wsNames.Range("A1:CY1"), Unique:=False
            End If
'clear from memory
            Set wsNames = Nothing
'clear clipboard
            Application.CutCopyMode = False
        Next
        .Select
    End With
 
progend:
    If Not wsFilter Is Nothing Then wsFilter.Delete
    With Application
        .ScreenUpdating = True: .DisplayAlerts = True
    End With
 
    If Err <> 0 Then MsgBox (Error(Err)), vbCritical, "Error"
     
End Sub

Sub AddSheet(ByVal HeadRange As Range, ByVal SheetName As String)
'resize header range to copy
    Set HeadRange = HeadRange.Rows(1).Offset(, 5).Resize(, 103)
'add new sheet
    Worksheets.Add(After:=Sheets(Sheets.Count)).Name = SheetName
'copy headers
   HeadRange.Copy
'apply formats
   With ActiveSheet.Rows(1)
    .PasteSpecial xlPasteValues
    .PasteSpecial xlPasteFormats
    .PasteSpecial xlPasteColumnWidths
   End With
'clear clipboard
   Application.CutCopyMode = False
End Sub

I have created a separate code to add new sheets - it looks busy but this is only because of applying formatting to match master sheet - if you only need to copy values then code can be reduced a little.

You will need to delete any existing sheets created by the previous code to ensure correct data is filtered to sheets.

With regards to your last question - as this is a new requirement I suggest start another thread.

Hope Helpful

Dave

Thank you SO MUCH Dave!

This solved my issue and I was able to get the sheets to export into txt files now as well.

I really appreciate your help with this.

 

[dmt32]

Thank you SO MUCH Dave!

This solved my issue and I was able to get the sheets to export into txt files now as well.

I really appreciate your help with this.

Glad update resolved for you - appreciate feedback

Dave

 

[PIERANDPORT]

Glad update resolved for you - appreciate feedback

Dave

Hi Dave -

I have one hopefully quick question.

Some of the cells contain "None" and this needs to be displayed in those cells. When the macro to split the sheets runs it keeps these cells but they are blank. So when I go to upload the text file to our system it errors out. Is there anyway to be able to include a "None" value in these cells? If you need specific cells I can provide them there is a handful or so.