none
Console Excel Sheet Data to convert to individual text file. RRS feed

  • Question

  • Hi Dude,

    I have a console excel spreadsheet data which I want to filter each combination data one by one and copy and paste into text file

    i.e. I would like an .xls file data with have the multiple rows records for cafeteria, operation,Strategy, human resource, copy the data visible data and paste with similar name in the text file (cafeteria.txt, strategy.txt)

    example : -

    Assume below is the data in excel sheet.

     

    Column A               ColumnB            ColumnC

    Cafeteria                 2500                  Q1

    Cafeteria                 1500                  Q1

    Cafeteria                 3400                  Q3

    Banana                   2500                  Q1

    Banana                   1500                  Q1

    Mix                         3400                  Q2

    Banana                   1500                  Q2

    Banana                   1500                  Q2

    Banana                   1500                  Q1

    Mix                         3400                  Q1

    Mix                         3400                  Q1

     What i want, filter each combination data of column A & Column C one by one with header and copy the visible cells data and create text file. i.e Cafeteria_Q1.txt, Cafeteria_Q3.txt,Banana_Q1.txt.

    What VBA code would I use to do this? and let me know if you require further info.

     Thanks for your help

    Raj

    Monday, April 22, 2013 7:09 AM

Answers

  • This macro will do what you want.

    Sub ExportDatabaseToSeparateFiles()
        'Export is based on the value in the desired column
        Dim myCell As Range
        Dim mySht As Worksheet
        Dim myName As String
        Dim rngData As Range
        Dim myShtName As String
        Dim KeyCol As String

        myShtName = ActiveSheet.Name
        KeyCol = "A"

        Set rngData = Intersect(ActiveCell.CurrentRegion, Range(KeyCol & "1").EntireColumn).Cells
        Set rngData = rngData.Offset(1, 0).Resize(rngData.Rows.Count - 1, 1)

        For Each myCell In rngData
            On Error GoTo NoSheet
            myName = Worksheets(myCell.Value & "_" & myCell(1, 3).Value).Name
            GoTo SheetExists:
    NoSheet:
            Set mySht = Worksheets.Add(Before:=Worksheets(1))
            mySht.Name = myCell.Value & "_" & myCell(1, 3).Value
            With myCell.CurrentRegion
                .AutoFilter Field:=1, Criteria1:=myCell.Value
                .AutoFilter Field:=3, Criteria1:=myCell(1, 3).Value
                .SpecialCells(xlCellTypeVisible).Copy _
                        mySht.Range("A1")
                mySht.Cells.EntireColumn.AutoFit
                .AutoFilter
            End With
            Resume
    SheetExists:
        Next myCell

        For Each mySht In ActiveWorkbook.Worksheets
            If mySht.Name <> myShtName Then
                mySht.Move
                Application.DisplayAlerts = False
                ActiveWorkbook.SaveAs "Workbook " & ActiveSheet.Name & ".txt", FileFormat:=xlText
                ActiveWorkbook.Close
                Application.DisplayAlerts = True
            End If
        Next mySht
    End Sub

    Monday, April 22, 2013 3:52 PM
  • Change

     ActiveWorkbook.SaveAs "Workbook " & ActiveSheet.Name & ".txt", FileFormat:=xlText

    to

     

     ActiveWorkbook.SaveAs "D:\Output Text file_Month\Workbook " & ActiveSheet.Name & ".txt", FileFormat:=xlText

    or if the month changes, something like

    ActiveWorkbook.SaveAs "D:\Output Text file_" & Format(Now,"MMMM") & "\Workbook " & ActiveSheet.Name & ".txt", FileFormat:=xlText

    • Marked as answer by Raz_master Tuesday, April 23, 2013 1:48 PM
    Tuesday, April 23, 2013 11:32 AM

All replies

  • This macro will do what you want.

    Sub ExportDatabaseToSeparateFiles()
        'Export is based on the value in the desired column
        Dim myCell As Range
        Dim mySht As Worksheet
        Dim myName As String
        Dim rngData As Range
        Dim myShtName As String
        Dim KeyCol As String

        myShtName = ActiveSheet.Name
        KeyCol = "A"

        Set rngData = Intersect(ActiveCell.CurrentRegion, Range(KeyCol & "1").EntireColumn).Cells
        Set rngData = rngData.Offset(1, 0).Resize(rngData.Rows.Count - 1, 1)

        For Each myCell In rngData
            On Error GoTo NoSheet
            myName = Worksheets(myCell.Value & "_" & myCell(1, 3).Value).Name
            GoTo SheetExists:
    NoSheet:
            Set mySht = Worksheets.Add(Before:=Worksheets(1))
            mySht.Name = myCell.Value & "_" & myCell(1, 3).Value
            With myCell.CurrentRegion
                .AutoFilter Field:=1, Criteria1:=myCell.Value
                .AutoFilter Field:=3, Criteria1:=myCell(1, 3).Value
                .SpecialCells(xlCellTypeVisible).Copy _
                        mySht.Range("A1")
                mySht.Cells.EntireColumn.AutoFit
                .AutoFilter
            End With
            Resume
    SheetExists:
        Next myCell

        For Each mySht In ActiveWorkbook.Worksheets
            If mySht.Name <> myShtName Then
                mySht.Move
                Application.DisplayAlerts = False
                ActiveWorkbook.SaveAs "Workbook " & ActiveSheet.Name & ".txt", FileFormat:=xlText
                ActiveWorkbook.Close
                Application.DisplayAlerts = True
            End If
        Next mySht
    End Sub

    Monday, April 22, 2013 3:52 PM
  • The codes very helpful

    I want to save all text files into specify location.(D:\Output Text file_Month)

    where the text files has been saved i could not identified.. Thanks

    regards

    Raj

    Tuesday, April 23, 2013 11:10 AM
  • Change

     ActiveWorkbook.SaveAs "Workbook " & ActiveSheet.Name & ".txt", FileFormat:=xlText

    to

     

     ActiveWorkbook.SaveAs "D:\Output Text file_Month\Workbook " & ActiveSheet.Name & ".txt", FileFormat:=xlText

    or if the month changes, something like

    ActiveWorkbook.SaveAs "D:\Output Text file_" & Format(Now,"MMMM") & "\Workbook " & ActiveSheet.Name & ".txt", FileFormat:=xlText

    • Marked as answer by Raz_master Tuesday, April 23, 2013 1:48 PM
    Tuesday, April 23, 2013 11:32 AM
  • Hey Dude,

    Small issue that I have data from A to Z and i try to filter the "H" Column & "M" Column but the below code does not support and i am setting the month as i need last month only that means below code taking the current month as per system. (i.e if the current month is April and i need for March) can you please help....

    Sub ExportDatabaseToSeparateFiles()
        'Export is based on the value in the desired column
        Dim myCell As Range
        Dim mySht As Worksheet
        Dim myName As String
        Dim mymonth As String
        Dim myyear As String
        Dim rngData As Range
        Dim myShtName As String
        Dim KeyCol As String

        myShtName = ActiveSheet.Name
        KeyCol = "H"

        Set rngData = Intersect(ActiveCell.CurrentRegion, Range(KeyCol & "1").EntireColumn).Cells
        Set rngData = rngData.Offset(1, 8).Resize(rngData.Rows.Count - 1, 1)

       
        For Each myCell In rngData
            On Error GoTo NoSheet
            myName = Worksheets(myCell.Value & "_" & myCell(1, 13).Value).Name
             GoTo SheetExists:
    NoSheet:
            Set mySht = Worksheets.Add(Before:=Worksheets(1))
            mySht.Name = myCell.Value & "_" & myCell(1, 13).Value
            With myCell.CurrentRegion
                .AutoFilter Field:=8, Criteria1:=myCell.Value
                .AutoFilter Field:=13, Criteria1:=myCell(1, 13).Value
                .SpecialCells(xlCellTypeVisible).Copy _
                        mySht.Range("A1")
                mySht.Cells.EntireColumn.AutoFit
                .AutoFilter
            End With
            Resume
    SheetExists:
        Next myCell
       
       
        mymonth = Month(Date)
        myyear = Year(Date)


        For Each mySht In ActiveWorkbook.Worksheets
            If mySht.Name <> myShtName Then
                mySht.Move
                Application.DisplayAlerts = False
                ActiveWorkbook.SaveAs "D:\Output Text file\" & ActiveSheet.Name & "_" & Format(Now, "MMMM") & "_" & myyear & ".txt", FileFormat:=xlText
                ActiveWorkbook.Close
                Application.DisplayAlerts = True
            End If
        Next mySht
    End Sub

     

     

     

    Saturday, April 27, 2013 12:23 PM
  • Here is a new version that allows you to set the two columns at the top - the code was written using your example, so this is more flexible (the indexing was dependent on the columns, and the second column was dependent on the first, so I changed it to be independent). And this creates the file as last month, not this month.

    Sub ExportDatabaseToSeparateFiles2()
         'Export is based on the value in the desired column
         Dim myCell As Range
         Dim mySht As Worksheet
         Dim shtNew As Worksheet
         Dim myName As String
         Dim mymonth As String
         Dim myyear As String
         Dim rngData As Range
         Dim myShtName As String
         Dim KeyCol As String
         Dim KeyCol2 As String

         myShtName = ActiveSheet.Name
         Set mySht = ActiveSheet
         KeyCol = "H"
         KeyCol2 = "M"

         Set rngData = Intersect(mySht.UsedRange, mySht.Range(KeyCol & "1").EntireColumn).Cells
         Set rngData = rngData.Offset(1, 0).Resize(rngData.Rows.Count - 1, 1)
       
         For Each myCell In rngData
             On Error GoTo NoSheet
             myName = Worksheets(myCell.Value & "_" & mySht.Cells(myCell.Row, KeyCol2).Value).Name
              GoTo SheetExists:
    NoSheet:
             Set shtNew = Worksheets.Add(Before:=Worksheets(1))
             shtNew.Name = myCell.Value & "_" & mySht.Cells(myCell.Row, KeyCol2).Value
             With myCell.CurrentRegion
                 .AutoFilter Field:=Range(KeyCol & "1").Column - .Column + 1, Criteria1:=myCell.Value
                 .AutoFilter Field:=Range(KeyCol2 & "1").Column - .Column + 1, Criteria1:=mySht.Cells(myCell.Row, KeyCol2).Value
                 .SpecialCells(xlCellTypeVisible).Copy _
                         shtNew.Range("A1")
                 shtNew.Cells.EntireColumn.AutoFit
                 .AutoFilter
             End With
             Resume
    SheetExists:
         Next myCell
        
        
         mymonth = Month(Date)
         myyear = Year(Date)


         For Each shtNew In ActiveWorkbook.Worksheets
             If shtNew.Name <> myShtName Then
                 shtNew.Move
                 Application.DisplayAlerts = False
                 ActiveWorkbook.SaveAs "D:\Output Text file\" & ActiveSheet.Name & _
                 "_" & Format(DateSerial(myyear, mymonth - 1, 1), "MMMM_yyyy") & ".txt", FileFormat:=xlText
                 ActiveWorkbook.Close
                 Application.DisplayAlerts = True
             End If
         Next shtNew
     End Sub


    Saturday, April 27, 2013 12:56 PM
  • Thanks dude, my first sheet is instruction tab (myins) and second is Database Tab (myshtname) but the text file creating instruction tab aswell. database,instruction tab should not move.....create text file..

    I have changed the code i.e     If shtNew.Name <> myShtName And myins Then

    shtnew.move and  to create the text file but it does not support me.. refer the below codes...

    Sub xlDatabase_to_txt()
         'Copy the columns H & M Data and paste to txt file
         'Export is based on the value in the desired column
         Dim myCell As Range
         Dim mySht As Worksheet
         Dim shtNew As Worksheet
         Dim myins As String
         Dim myName As String
         Dim mymonth As String
         Dim myyear As String
         Dim rngData As Range
         Dim myShtName As String
         Dim KeyCol As String
         Dim KeyCol2 As String
        
         Application.DisplayAlerts = False
         Application.ScreenUpdating = False
         Application.CutCopyMode = False
           
        
         myins = ActiveSheet.Name
         Sheets("Database").Select
         myShtName = ActiveSheet.Name
         Set mySht = ActiveSheet
         KeyCol = "H"
         KeyCol2 = "M"

         Set rngData = Intersect(mySht.UsedRange, mySht.Range(KeyCol & "1").EntireColumn).Cells
         Set rngData = rngData.Offset(1, 0).Resize(rngData.Rows.Count - 1, 1)
       
         For Each myCell In rngData
             On Error GoTo NoSheet
             myName = Worksheets(myCell.Value & "_" & mySht.Cells(myCell.Row, KeyCol2).Value).Name
              GoTo SheetExists:
    NoSheet:
             Set shtNew = Worksheets.Add(After:=Worksheets(2))
             shtNew.Name = myCell.Value & "_" & mySht.Cells(myCell.Row, KeyCol2).Value
             With myCell.CurrentRegion
                 .AutoFilter Field:=Range(KeyCol & "1").Column - .Column + 1, Criteria1:=myCell.Value
                 .AutoFilter Field:=Range(KeyCol2 & "1").Column - .Column + 1, Criteria1:=mySht.Cells(myCell.Row, KeyCol2).Value
                 .SpecialCells(xlCellTypeVisible).Copy _
                         shtNew.Range("A1")
                 shtNew.Cells.EntireColumn.AutoFit
                 .AutoFilter
             End With
             Resume
    SheetExists:
         Next myCell
        
        
         mymonth = Month(Date)
         myyear = Year(Date)


         For Each shtNew In ActiveWorkbook.Worksheets
             If shtNew.Name <> myShtName And myins Then
                 shtNew.Move
                 Application.DisplayAlerts = False
                 ActiveWorkbook.SaveAs "D:\Output Text file\" & ActiveSheet.Name & _
                 "_" & Format(DateSerial(myyear, mymonth - 1, 1), "MMMM-yyyy") & ".txt", FileFormat:=xlText
                 ActiveWorkbook.Close
                
                
             End If
         Next shtNew
        
                 Application.DisplayAlerts = True
                 Application.ScreenUpdating = True
                 Application.CutCopyMode = True
     End Sub

     

     

     

    Sunday, May 5, 2013 3:20 AM
  •  If shtNew.Name <> myShtName And shtNew.Name <> myins Then
    Sunday, May 5, 2013 2:44 PM