Checking contents

[Edgar Thoemmes]

Hi

See thread below from yesterday.

Sorry dont think i explained myself properly.

With the current code i have to manually enter each
different supplier in the input box for it to copy to a
new sheet. What i want is for this to happen automatically
when i run the macro.

The data that is in column T is common to each supplier
reference which is in column H so i would like to name the
new sheet by the value in column t.

Thanks for your help again.

Edgar

Edgar,

Where in column T is the criteria. it can't be the whole
column?


It already processes the entire sheet, the autofilter
process will select
all items that match, so I am, not sure what you mean by
the second part.
--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)

message

Hi

This works well but there are a couple of problems that I
need to sort.

Firstly instead of having an inputbox to name the new
sheet i would like the values to be copied to a new
workbook and to name the workbook by the value in
column "T".

I would also like the macro to loop through the entire
sheet and finish when it gets to the end.

Thanks

Edgar,

Here's a macro to do it

Sub CopyInvoices()
Dim sCriteria As String
Dim sOriginal As String
Dim sNew As String

sCriteria = InputBox("Input Supplier Ref to select")
If sCriteria <> "" Then
With ActiveWorkbook
sOriginal = .ActiveSheet.Name
.Worksheets.Add After:=.Worksheets
(.Worksheets.Count)
.ActiveSheet.Name = sCriteria
sNew = .ActiveSheet.Name
.Worksheets(sOriginal).Activate
With .ActiveSheet
.Rows(1).Insert
.Range("H1").Value = "Test"
.Columns("H:H").AutoFilter Field:=1,
Criteria1:=sCriteria
.Cells.SpecialCells(xlCellTypeVisible).Copy
End With
.Worksheets(sNew).Paste
.Worksheets(sNew).Rows(1).EntireRow.Delete
.Worksheets(sOriginal).Rows(1).EntireRow.Delete
End With
End If

Application.CutCopyMode = False

End Sub


--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)

"Edgar Thoemmes" <[email protected]>
wrote in message

 

[Bob Phillips]

Edgar,

If T holds all the supplier's, then this should do it

Sub CopyInvoices()
Dim sCriteria As String
Dim sOriginal As String
Dim sNew As String
Dim i As Long

With ActiveWorkbook

With .ActiveSheet
.Rows(1).Insert
.Range("H1").Value = "Test"
sOriginal = .Name
End With

For i = 1 To .ActiveSheet.Cells(Rows.Count, "T").End(xlUp).Row
sCriteria = .ActiveSheet.Cells(i, "T").Value
If sCriteria <> "" Then
.Worksheets.Add After:=.Worksheets(.Worksheets.Count)
.ActiveSheet.Name = sCriteria
sNew = .ActiveSheet.Name
.Worksheets(sOriginal).Activate
With .ActiveSheet
.Columns("H:H").AutoFilter Field:=1,
Criteria1:=sCriteria
.Cells.SpecialCells(xlCellTypeVisible).Copy
End With
With .Worksheets(sNew)
.Paste
.Rows(1).EntireRow.Delete
End With
End If
Next i

.Worksheets(sOriginal).Rows(1).EntireRow.Delete

End With

Application.CutCopyMode = False

End Sub


--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)

 

[Edgar]

Hi

I have tried this and it seems to be working up to a point
and then it falls down and displays the error message:

"Run time error '1004':
Cannot rename a sheet to the same name as another sheet"

I have shown below a basic version of my table

Column H(Supplier ID) T(Payment no) U(Inv no)
112585 912232 565225Taylor
112585 912232 642235Herorl
112585 912232 665525FSJJHAJ
134225 995425 6222255jkhgl
134225 995425 645464lskegk
154236 902544 664644wejgrw

With the above table i need it to create 3 new sheets with
the name 912232, 995425 and 902544 and copy all the
invoice numbers for the relevant invoices and some other
columns that i will add in later to the new sheet for that
specific payment no.

What i think it is doing at the moment is trying to create
a new sheet for every payment no line which is causing the
error i just dont know how to fix it.

Can anyone help - thread below!!!

Thanks so much

Edgar Thoemmes

-----Original Message-----
Edgar,

If T holds all the supplier's, then this should do it

Sub CopyInvoices()
Dim sCriteria As String
Dim sOriginal As String
Dim sNew As String
Dim i As Long

With ActiveWorkbook

With .ActiveSheet
.Rows(1).Insert
.Range("H1").Value = "Test"
sOriginal = .Name
End With

For i = 1 To .ActiveSheet.Cells

(Rows.Count, "T").End(xlUp).Row

 

[Bob Phillips]

Edgar,

You are really testing my ability to read your mind <G>.

I assumed T holds uynique values, and as you say, it is trying to create a
sheet per row based upon that assumtion all is okay, based upon reality, itr
is not.

Another version.

Sub CopyInvoices()
Dim sCriteria As String
Dim sOriginal As String
Dim sNew As String
Dim i As Long

With ActiveWorkbook

With .ActiveSheet
.Rows(1).Insert
.Range("H1").Value = "Test"
sOriginal = .Name
End With

For i = 1 To .ActiveSheet.Cells(Rows.Count, "T").End(xlUp).Row
sCriteria = .ActiveSheet.Cells(i, "T").Value
If sCriteria <> "" And sCriteria <> .ActiveSheet.Cells(i - 1,
"T").Value Then
.Worksheets.Add After:=.Worksheets(.Worksheets.Count)
.ActiveSheet.Name = sCriteria
sNew = .ActiveSheet.Name
.Worksheets(sOriginal).Activate
With .ActiveSheet
.Columns("H:H").AutoFilter Field:=1,
Criteria1:=sCriteria
.Cells.SpecialCells(xlCellTypeVisible).Copy
End With
With .Worksheets(sNew)
.Paste
.Rows(1).EntireRow.Delete
End With
End If
Next i

.Worksheets(sOriginal).Rows(1).EntireRow.Delete

End With

Application.CutCopyMode = False

End Sub

--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)

 

[Bob Phillips]

Edgar,

Let's cut to the quick.

Why not send me the workbook, and I can see what I can do.

--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)