crop files

I've a file with this structure
Code value
0001 dfdf
0002 ddgdfg
0001 dsdfsd
0001dfdgdsgds
0002 defert

I'd like to crop this file in 2 different files ..one for 0001 and the
other for 0002 with of course Code value for both and then block a cell
in both.
the name of the file and the name of the sheet should be given with a
textbox input and they will be the same for both..
the directory will be the same of the main file.
any hints??
or a guide I should follow since I'd like to learn and do everything by
myself???
thanks
Rossella

Try Data>Filter>Advanced Filter

HTH
--
AP

"Rossella" <[email protected]> a écrit dans le message de
news:[email protected]...
> I've a file with this structure
> Code value
> 0001 dfdf
> 0002 ddgdfg
> 0001 dsdfsd
> 0001dfdgdsgds
> 0002 defert
>
> I'd like to crop this file in 2 different files ..one for 0001 and the
> other for 0002 with of course Code value for both and then block a cell
> in both.
> the name of the file and the name of the sheet should be given with a
> textbox input and they will be the same for both..
> the directory will be the same of the main file.
> any hints??
> or a guide I should follow since I'd like to learn and do everything by
> myself???
> thanks
> Rossella
>

I know that but it doesn't do what I want automatically

Assume main file as excel file and Code in range A1, try this.

Sub cropfile()
Dim file1, file2, filename
Dim wk As Workbook, bk1 As Workbook, bk2 As Workbook
Dim code1, code2
Dim head As String
On Error GoTo errhandler

MsgBox "Select main file"
filename = Application.GetOpenFilename _
(FileFilter:="all file(*.*),*.*", MultiSelect:=False)
If VarType(filename) = vbBoolean Then
Exit Sub
End If
Workbooks.Open filename
head = "a1" '<<==Change here if Code not in A1
Set wk = ActiveWorkbook
code1 = Range(head)(2, 1)
Dim i As Long
For i = 0 To Range(head)(Cells.Rows.count, 1). _
End(xlUp).Row - 3
If code1 <> Range(head)(i + 3, 1) Then
code2 = Range(head)(i + 3, 1)
Exit For
End If
Next
file1 = Application.InputBox("INPUT FIRST FILE NAME")
If file1 = False Then
Exit Sub
End If
file2 = Application.InputBox("INPUT SECOND FILE NAME")
If file2 = False Then
Exit Sub
End If
If file1 = file2 Then
MsgBox "Two have the same file name"
Exit Sub
End If

Application.ScreenUpdating = False
Set bk1 = Workbooks.Add
Set bk2 = Workbooks.Add

bk1.Worksheets(1).Name = file1
bk2.Worksheets(1).Name = file2
wk.ActiveSheet.Range(head).AutoFilter _
field:=1, _
Criteria1:=code1
wk.ActiveSheet.Range(head).CurrentRegion.Copy _
bk1.Worksheets(1).Range(head)
Application.CutCopyMode = False
wk.ActiveSheet.Range(head).AutoFilter _
field:=1, _
Criteria1:=code2
wk.ActiveSheet.Range(head).CurrentRegion.Copy _
bk2.Worksheets(1).Range(head)
Application.CutCopyMode = False
wk.ActiveSheet.Range(head).AutoFilter
ChDir wk.Path
bk1.SaveAs file1 & ".xls"
bk1.Close
bk2.SaveAs file2 & ".xls"
bk2.Close
Exit Sub
errhandler:
MsgBox "error occured"
End Sub

keizi

"Rossella" <[email protected]> wrote in message
news:[email protected]...
> I've a file with this structure
> Code value
> 0001 dfdf
> 0002 ddgdfg
> 0001 dsdfsd
> 0001dfdgdsgds
> 0002 defert
>
> I'd like to crop this file in 2 different files ..one for 0001 and the
> other for 0002 with of course Code value for both and then block a
cell
> in both.
> the name of the file and the name of the sheet should be given with a
> textbox input and they will be the same for both..
> the directory will be the same of the main file.
> any hints??
> or a guide I should follow since I'd like to learn and do everything
by
> myself???
> thanks
> Rossella
>

thanks..it works..but the first column will soon be...
0001-l
0001-l
0002-k
0003-g
....
....

...
....
0060-lo

is it possible to create a cycle that create a file for every different
value of column 1?

Try this. If you input file name as e.g. "test", then it will make files
named as "test_0", "test_01" etc.(it depends on how many diffrent values
are)
i added function deldup to pick up different values.

Sub cropfile1()
Dim file1, file2, filename
Dim wk As Workbook, bk1 As Workbook, bk2 As Workbook
Dim code1, code2
Dim s
Dim head As String
On Error GoTo errhandler

MsgBox "Select main file"
filename = Application.GetOpenFilename _
(FileFilter:="all file(*.*),*.*", MultiSelect:=False)
If VarType(filename) = vbBoolean Then
Exit Sub
End If
Workbooks.Open filename
head = "a1" '<<==Change here if Code not in A1
Set wk = ActiveWorkbook
s = deldup(Range(head)(2, 1).Resize(Range(head) _
(Cells.Rows.count, 1).End(xlUp).Row - 1, 1))
file1 = Application.InputBox("INPUT FILE NAME")
If file1 = False Then
Exit Sub
End If
Application.ScreenUpdating = False
Dim i
For i = LBound(s) To UBound(s)
Set bk1 = Workbooks.Add
file2 = file1 & "_" & Trim(str(i))
bk1.Worksheets(1).Name = file2
wk.ActiveSheet.Range(head).AutoFilter _
field:=1, _
Criteria1:=s(i)
wk.ActiveSheet.Range(head).CurrentRegion.Copy _
bk1.Worksheets(1).Range(head)
Application.CutCopyMode = False
wk.ActiveSheet.Range(head).AutoFilter
bk1.SaveAs wk.Path & Application.PathSeparator _
& file2 & ".xls"
bk1.Close
Set bk1 = Nothing
Next
Exit Sub
errhandler:
MsgBox "error occured"
End Sub

Function deldup(rng As Range) As Variant
Dim dic, ar, min
Dim s As Range
Dim i As Long, j As Long, k As Long
Set dic = CreateObject("Scripting.Dictionary")
j = 0
ReDim ar(rng.count - 1)
For Each s In rng
If dic.exists(s.value) Then
dic(s.value) = dic(s.value) + 1
Else
dic.Add s.value, 1
ar(j) = s.value
j = j + 1
End If
Next
ReDim Preserve ar(j - 1)
deldup = ar
End Function

keizi

"Rossella" <[email protected]> wrote in message
news:[email protected]...
> thanks..it works..but the first column will soon be...
> 0001-l
> 0001-l
> 0002-k
> 0003-g
> ...
> ...
>
> ..
> ...
> 0060-lo
>
> is it possible to create a cycle that create a file for every
different
> value of column 1?
>

got the errhandler message..

i've no idea about this.
run the macro with commenting the statement below adding '
'On Error GoTo errhandler
then it will stop showing error message and highlight the line error
occured.
let me know the error message and the line error occured.
or if you don't mind, could you send me your data file to
[email protected]?
then i could check it by my side.

keizi

"Rossella" <[email protected]> wrote in message
news:[email protected]...
> got the errhandler message..
>

just an idea..where are code1,code 2 used??I I see their declaration
but nothing else

sorry, when i changed the original code, i forgot to delete code1,
code2. besides these, file2 and bk2 is not needed any more. but i think
these are nothing with the cause of error.

keizi

"Rossella" <[email protected]> wrote in message
news:[email protected]...
> just an idea..where are code1,code 2 used??I I see their declaration
> but nothing else
>