Hi,

I have a spreadsheet which general information, that I need to cut and paste
into another workbook and save as a delimited txt file.

The current spreadsheet I am working on contains 8 columns. In cell D, I
have a series of numbers that Cells E, F, G and H link to. - Im not really
interested in Columns A-C.

Cell D may contain anything from 1 row to 100+ rows of the same number. I
need to filter on a particular number (if I put the filter application on it
shows me each unique number) and once filtered I need to copy and past the
contents of Cells D, E, F, G and H to another workbook and save this as a
"Text (tab delimited) (*txt)".

To do this manually is a right pain in the rear as the spreadsheet is
approx. 11652 rows, which is ever growing.

I wanted to know if there is a way I can write/create a macro for this
spreadsheet, so we can run it on a weekly basis if any more information gets
added.

Your help would be much appreciated!

Thanks

T-bone!

This expects headers in D1.

Then it does an advanced filter to show the unique entries
(data|filter|advancedfilter in xl2003 menus).

Then it keeps track of those visible cells and applies data|filter|autofilter to
column D for each one of those unique entries.

It saves the files using each unique value--Hopefully, they won't be invalid
filenames!

And stores them in C:\temp. Make sure the output folder exists before you test
it.

Option Explicit
Sub testme()

Dim myCell As Range
Dim myRng As Range
Dim myUniques As Range
Dim VRng As Range
Dim wks As Worksheet
Dim tempWks As Worksheet

Set wks = Worksheets("sheet1")
With wks
'remove any existing autofilter
.AutoFilterMode = False
Set myRng = .Range("D1", .Cells(.Rows.Count, "D").End(xlUp))
With myRng
.AdvancedFilter action:=xlFilterInPlace, unique:=True

Set myUniques = Nothing
On Error Resume Next
'come down one row to avoid the header
Set myUniques = .Resize(.Rows.Count - 1, 1).Offset(1, 0) _
.Cells.SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If myUniques Is Nothing Then
MsgBox "Nothing under D1!"
Exit Sub
End If

For Each myCell In myUniques.Cells
.AutoFilter field:=1, Criteria1:=myCell.Value
Set VRng = Nothing
On Error Resume Next
'come down one row, but include 5 columns!
Set VRng = .Resize(.Rows.Count - 1, 5).Offset(1, 0) _
.Cells.SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If VRng Is Nothing Then
MsgBox "something bad happened with: " & myCell.Value
Exit Sub
End If
Set tempWks = Workbooks.Add(1).Worksheets(1)
VRng.Copy _
Destination:=tempWks.Range("A1")

With tempWks.Parent
Application.DisplayAlerts = False
.SaveAs Filename:="C:\temp\" & myCell.Value & ".txt", _
FileFormat:=xlText
Application.DisplayAlerts = True
.Close savechanges:=False
End With
Next myCell
End With
.AutoFilterMode = False
End With

End Sub


T-bone wrote:

Hi,

I have a spreadsheet which general information, that I need to cut and paste
into another workbook and save as a delimited txt file.

The current spreadsheet I am working on contains 8 columns. In cell D, I
have a series of numbers that Cells E, F, G and H link to. - Im not really
interested in Columns A-C.

Cell D may contain anything from 1 row to 100+ rows of the same number. I
need to filter on a particular number (if I put the filter application on it
shows me each unique number) and once filtered I need to copy and past the
contents of Cells D, E, F, G and H to another workbook and save this as a
"Text (tab delimited) (*txt)".

To do this manually is a right pain in the rear as the spreadsheet is
approx. 11652 rows, which is ever growing.

I wanted to know if there is a way I can write/create a macro for this
spreadsheet, so we can run it on a weekly basis if any more information gets
added.

Your help would be much appreciated!

Thanks

T-bone!

--

Dave Peterson

Hi Dave,

Do you think it would be ok to send you my spreadhseet - I can't seem to get
the macro to work and I'm unfortunatley not tecnically minded :-(

Thanks

T-bone

"Dave Peterson" wrote:

This expects headers in D1.

Then it does an advanced filter to show the unique entries
(data|filter|advancedfilter in xl2003 menus).

Then it keeps track of those visible cells and applies data|filter|autofilter to
column D for each one of those unique entries.

It saves the files using each unique value--Hopefully, they won't be invalid
filenames!

And stores them in C:\temp. Make sure the output folder exists before you test
it.

Option Explicit
Sub testme()

Dim myCell As Range
Dim myRng As Range
Dim myUniques As Range
Dim VRng As Range
Dim wks As Worksheet
Dim tempWks As Worksheet

Set wks = Worksheets("sheet1")
With wks
'remove any existing autofilter
.AutoFilterMode = False
Set myRng = .Range("D1", .Cells(.Rows.Count, "D").End(xlUp))
With myRng
.AdvancedFilter action:=xlFilterInPlace, unique:=True

Set myUniques = Nothing
On Error Resume Next
'come down one row to avoid the header
Set myUniques = .Resize(.Rows.Count - 1, 1).Offset(1, 0) _
.Cells.SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If myUniques Is Nothing Then
MsgBox "Nothing under D1!"
Exit Sub
End If

For Each myCell In myUniques.Cells
.AutoFilter field:=1, Criteria1:=myCell.Value
Set VRng = Nothing
On Error Resume Next
'come down one row, but include 5 columns!
Set VRng = .Resize(.Rows.Count - 1, 5).Offset(1, 0) _
.Cells.SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If VRng Is Nothing Then
MsgBox "something bad happened with: " & myCell.Value
Exit Sub
End If
Set tempWks = Workbooks.Add(1).Worksheets(1)
VRng.Copy _
Destination:=tempWks.Range("A1")

With tempWks.Parent
Application.DisplayAlerts = False
.SaveAs Filename:="C:\temp\" & myCell.Value & ".txt", _
FileFormat:=xlText
Application.DisplayAlerts = True
.Close savechanges:=False
End With
Next myCell
End With
.AutoFilterMode = False
End With

End Sub


T-bone wrote:

Hi,

I have a spreadsheet which general information, that I need to cut and paste
into another workbook and save as a delimited txt file.

The current spreadsheet I am working on contains 8 columns. In cell D, I
have a series of numbers that Cells E, F, G and H link to. - Im not really
interested in Columns A-C.

Cell D may contain anything from 1 row to 100+ rows of the same number. I
need to filter on a particular number (if I put the filter application on it
shows me each unique number) and once filtered I need to copy and past the
contents of Cells D, E, F, G and H to another workbook and save this as a
"Text (tab delimited) (*txt)".

To do this manually is a right pain in the rear as the spreadsheet is
approx. 11652 rows, which is ever growing.

I wanted to know if there is a way I can write/create a macro for this
spreadsheet, so we can run it on a weekly basis if any more information gets
added.

Your help would be much appreciated!

Thanks

T-bone!

--

Dave Peterson

No thanks.

Describe your problems in plain text and post it in this thread. You'll have
lots of potential helpers.



T-bone wrote:

Hi Dave,

Do you think it would be ok to send you my spreadhseet - I can't seem to get
the macro to work and I'm unfortunatley not tecnically minded :-(

Thanks

T-bone

"Dave Peterson" wrote:

This expects headers in D1.

Then it does an advanced filter to show the unique entries
(data|filter|advancedfilter in xl2003 menus).

Then it keeps track of those visible cells and applies data|filter|autofilter to
column D for each one of those unique entries.

It saves the files using each unique value--Hopefully, they won't be invalid
filenames!

And stores them in C:\temp. Make sure the output folder exists before you test
it.

Option Explicit
Sub testme()

Dim myCell As Range
Dim myRng As Range
Dim myUniques As Range
Dim VRng As Range
Dim wks As Worksheet
Dim tempWks As Worksheet

Set wks = Worksheets("sheet1")
With wks
'remove any existing autofilter
.AutoFilterMode = False
Set myRng = .Range("D1", .Cells(.Rows.Count, "D").End(xlUp))
With myRng
.AdvancedFilter action:=xlFilterInPlace, unique:=True

Set myUniques = Nothing
On Error Resume Next
'come down one row to avoid the header
Set myUniques = .Resize(.Rows.Count - 1, 1).Offset(1, 0) _
.Cells.SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If myUniques Is Nothing Then
MsgBox "Nothing under D1!"
Exit Sub
End If

For Each myCell In myUniques.Cells
.AutoFilter field:=1, Criteria1:=myCell.Value
Set VRng = Nothing
On Error Resume Next
'come down one row, but include 5 columns!
Set VRng = .Resize(.Rows.Count - 1, 5).Offset(1, 0) _
.Cells.SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If VRng Is Nothing Then
MsgBox "something bad happened with: " & myCell.Value
Exit Sub
End If
Set tempWks = Workbooks.Add(1).Worksheets(1)
VRng.Copy _
Destination:=tempWks.Range("A1")

With tempWks.Parent
Application.DisplayAlerts = False
.SaveAs Filename:="C:\temp\" & myCell.Value & ".txt", _
FileFormat:=xlText
Application.DisplayAlerts = True
.Close savechanges:=False
End With
Next myCell
End With
.AutoFilterMode = False
End With

End Sub


T-bone wrote:

Hi,

I have a spreadsheet which general information, that I need to cut and paste
into another workbook and save as a delimited txt file.

The current spreadsheet I am working on contains 8 columns. In cell D, I
have a series of numbers that Cells E, F, G and H link to. - Im not really
interested in Columns A-C.

Cell D may contain anything from 1 row to 100+ rows of the same number. I
need to filter on a particular number (if I put the filter application on it
shows me each unique number) and once filtered I need to copy and past the
contents of Cells D, E, F, G and H to another workbook and save this as a
"Text (tab delimited) (*txt)".

To do this manually is a right pain in the rear as the spreadsheet is
approx. 11652 rows, which is ever growing.

I wanted to know if there is a way I can write/create a macro for this
spreadsheet, so we can run it on a weekly basis if any more information gets
added.

Your help would be much appreciated!

Thanks

T-bone!

--

Dave Peterson


--

Dave Peterson

I got it to work! Thanks so much for your time and help! Much appreciated!
;o)

"Dave Peterson" wrote:

No thanks.

Describe your problems in plain text and post it in this thread. You'll have
lots of potential helpers.



T-bone wrote:

Hi Dave,

Do you think it would be ok to send you my spreadhseet - I can't seem to get
the macro to work and I'm unfortunatley not tecnically minded :-(

Thanks

T-bone

"Dave Peterson" wrote:

This expects headers in D1.

Then it does an advanced filter to show the unique entries
(data|filter|advancedfilter in xl2003 menus).

Then it keeps track of those visible cells and applies data|filter|autofilter to
column D for each one of those unique entries.

It saves the files using each unique value--Hopefully, they won't be invalid
filenames!

And stores them in C:\temp. Make sure the output folder exists before you test
it.

Option Explicit
Sub testme()

Dim myCell As Range
Dim myRng As Range
Dim myUniques As Range
Dim VRng As Range
Dim wks As Worksheet
Dim tempWks As Worksheet

Set wks = Worksheets("sheet1")
With wks
'remove any existing autofilter
.AutoFilterMode = False
Set myRng = .Range("D1", .Cells(.Rows.Count, "D").End(xlUp))
With myRng
.AdvancedFilter action:=xlFilterInPlace, unique:=True

Set myUniques = Nothing
On Error Resume Next
'come down one row to avoid the header
Set myUniques = .Resize(.Rows.Count - 1, 1).Offset(1, 0) _
.Cells.SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If myUniques Is Nothing Then
MsgBox "Nothing under D1!"
Exit Sub
End If

For Each myCell In myUniques.Cells
.AutoFilter field:=1, Criteria1:=myCell.Value
Set VRng = Nothing
On Error Resume Next
'come down one row, but include 5 columns!
Set VRng = .Resize(.Rows.Count - 1, 5).Offset(1, 0) _
.Cells.SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If VRng Is Nothing Then
MsgBox "something bad happened with: " & myCell.Value
Exit Sub
End If
Set tempWks = Workbooks.Add(1).Worksheets(1)
VRng.Copy _
Destination:=tempWks.Range("A1")

With tempWks.Parent
Application.DisplayAlerts = False
.SaveAs Filename:="C:\temp\" & myCell.Value & ".txt", _
FileFormat:=xlText
Application.DisplayAlerts = True
.Close savechanges:=False
End With
Next myCell
End With
.AutoFilterMode = False
End With

End Sub


T-bone wrote:

Hi,

I have a spreadsheet which general information, that I need to cut and paste
into another workbook and save as a delimited txt file.

The current spreadsheet I am working on contains 8 columns. In cell D, I
have a series of numbers that Cells E, F, G and H link to. - Im not really
interested in Columns A-C.

Cell D may contain anything from 1 row to 100+ rows of the same number. I
need to filter on a particular number (if I put the filter application on it
shows me each unique number) and once filtered I need to copy and past the
contents of Cells D, E, F, G and H to another workbook and save this as a
"Text (tab delimited) (*txt)".

To do this manually is a right pain in the rear as the spreadsheet is
approx. 11652 rows, which is ever growing.

I wanted to know if there is a way I can write/create a macro for this
spreadsheet, so we can run it on a weekly basis if any more information gets
added.

Your help would be much appreciated!

Thanks

T-bone!

--

Dave Peterson


--

Dave Peterson

Glad you got it working!

T-bone wrote:

I got it to work! Thanks so much for your time and help! Much appreciated!
;o)

"Dave Peterson" wrote:

No thanks.

Describe your problems in plain text and post it in this thread. You'll have
lots of potential helpers.



T-bone wrote:

Hi Dave,

Do you think it would be ok to send you my spreadhseet - I can't seem to get
the macro to work and I'm unfortunatley not tecnically minded :-(

Thanks

T-bone

"Dave Peterson" wrote:

This expects headers in D1.

Then it does an advanced filter to show the unique entries
(data|filter|advancedfilter in xl2003 menus).

Then it keeps track of those visible cells and applies data|filter|autofilter to
column D for each one of those unique entries.

It saves the files using each unique value--Hopefully, they won't be invalid
filenames!

And stores them in C:\temp. Make sure the output folder exists before you test
it.

Option Explicit
Sub testme()

Dim myCell As Range
Dim myRng As Range
Dim myUniques As Range
Dim VRng As Range
Dim wks As Worksheet
Dim tempWks As Worksheet

Set wks = Worksheets("sheet1")
With wks
'remove any existing autofilter
.AutoFilterMode = False
Set myRng = .Range("D1", .Cells(.Rows.Count, "D").End(xlUp))
With myRng
.AdvancedFilter action:=xlFilterInPlace, unique:=True

Set myUniques = Nothing
On Error Resume Next
'come down one row to avoid the header
Set myUniques = .Resize(.Rows.Count - 1, 1).Offset(1, 0) _
.Cells.SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If myUniques Is Nothing Then
MsgBox "Nothing under D1!"
Exit Sub
End If

For Each myCell In myUniques.Cells
.AutoFilter field:=1, Criteria1:=myCell.Value
Set VRng = Nothing
On Error Resume Next
'come down one row, but include 5 columns!
Set VRng = .Resize(.Rows.Count - 1, 5).Offset(1, 0) _
.Cells.SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If VRng Is Nothing Then
MsgBox "something bad happened with: " & myCell.Value
Exit Sub
End If
Set tempWks = Workbooks.Add(1).Worksheets(1)
VRng.Copy _
Destination:=tempWks.Range("A1")

With tempWks.Parent
Application.DisplayAlerts = False
.SaveAs Filename:="C:\temp\" & myCell.Value & ".txt", _
FileFormat:=xlText
Application.DisplayAlerts = True
.Close savechanges:=False
End With
Next myCell
End With
.AutoFilterMode = False
End With

End Sub


T-bone wrote:

Hi,

I have a spreadsheet which general information, that I need to cut and paste
into another workbook and save as a delimited txt file.

The current spreadsheet I am working on contains 8 columns. In cell D, I
have a series of numbers that Cells E, F, G and H link to. - Im not really
interested in Columns A-C.

Cell D may contain anything from 1 row to 100+ rows of the same number. I
need to filter on a particular number (if I put the filter application on it
shows me each unique number) and once filtered I need to copy and past the
contents of Cells D, E, F, G and H to another workbook and save this as a
"Text (tab delimited) (*txt)".

To do this manually is a right pain in the rear as the spreadsheet is
approx. 11652 rows, which is ever growing.

I wanted to know if there is a way I can write/create a macro for this
spreadsheet, so we can run it on a weekly basis if any more information gets
added.

Your help would be much appreciated!

Thanks

T-bone!

--

Dave Peterson


--

Dave Peterson


--

Dave Peterson