Copy data in new sheets from criteria using VBA

[bambinos83]

I have a huge database with a lot of 0 and 1.

When there is the number 1, I would like to copy in a new sheet th
name of the line (which is a time) and that, for every row.

I attached a part of my database to this message and here is a
example. In the row L, the number 1 appears twice. I'd like to have, i
the sheet "Horaires", 0 and 525, which appear in column C.

I think the best way to do this is using VBA but my knowledge of VBA i
too low. I need some guidelines to get through it

+-------------------------------------------------------------------
|Filename: ex.zip
|Download: http://www.excelforum.com/attachment.php?postid=4475
+-------------------------------------------------------------------

 

[Ardus Petus]

Could you give an example of what you expect in sheet "Horaires" ?

TIA
--
AP

"bambinos83" <[email protected]> a
écrit dans le message de
news:[email protected]...

 

[bambinos83]

I modified the sheet "Horaires" in the foloowing worksheet with a
example of what I'd like to have

+-------------------------------------------------------------------
|Filename: ex.zip
|Download: http://www.excelforum.com/attachment.php?postid=4476
+-------------------------------------------------------------------

 

[Ardus Petus]

Voici la macro:

Cordialement,
--
AP

'----------------------------------
Sub transpose()
Dim rHeureVoyage As Range
Dim rTrace As Range
Worksheets("Test").Activate 'Make it active sheet
For Each rHeureVoyage In Range( _
Cells(4, "C"), _
Cells(Rows.Count, "C").End(xlUp))

For Each rTrace In Range( _
rHeureVoyage.Offset(0, 1), _
rHeureVoyage.Offset(0, 1).End(xlToRight))

If rTrace.Value = 1 Then
Set rdest = Worksheets("Horaires").Cells( _
3, _
rTrace.Column - 2)
Do While rdest.Value <> ""
Set rdest = rdest.Offset(1, 0)
Loop
rdest.Value = rHeureVoyage.Value
End If
Next rTrace
Next rHeureVoyage
End Sub
'---------------------------------------
"bambinos83" <[email protected]> a
écrit dans le message de
news:[email protected]...

 

[bambinos83]

Wow. Merci beaucoup... Thanks a lot!! This is great and it will save m
loads of time!! I have another issue with VBA but I won't abuse fro
you... I'll give it a shot!

Thanks again! :

 

[Ardus Petus]

Come on, I've got plenty of time...

Cheers
--
AP

"bambinos83" <[email protected]> a
écrit dans le message de
news:[email protected]...

 

[bambinos83]

Well, don't worry about that second problem... It's not usefull anymore
I have a question about the previous macro though. In the DB that i
produced by running the code, is there a way to sort the results in a
ascending order by column and to delete any values that is there mor
than once in each column.

By doing this, I want to have some sort of clean timetable.

I attached the resulting table to this reply

+-------------------------------------------------------------------
|Filename: ex2.zip
|Download: http://www.excelforum.com/attachment.php?postid=4477
+-------------------------------------------------------------------

 

[Ardus Petus]

Here's the code.

Yours,
--
AP

'---------------------------------------------
Sub SortResults()
' Sort result columns in ascendig order, elimitating dupes
Dim rngHeader As Range
Dim rngdata As Range
Dim rngVal As Range
Dim iRow As Long
Worksheets("Horaires").Activate

For Each rngHeader In Range( _
Range("B2"), _
Range("B2").End(xlToRight))

Set rngdata = rngHeader.Offset(1, 0) 'First row of data
If rngdata.Value <> "" Then 'Non-Empty column
Set rngdata = Range( _
rngdata, _
Cells(Rows.Count, rngdata.Column).End(xlUp))
If rngdata.Count > 1 Then 'More than 1 row
rngdata.Sort rngdata.Cells(1), xlAscending 'Sort data
For iRow = rngdata.Count To 2 Step -1
If rngdata.Cells(iRow).Value = _
rngdata.Cells(iRow - 1).Value _
Then rngdata.Cells(iRow).Delete xlUp 'dupe
Next iRow
End If
End If
Next rngHeader
End Sub
'--------------------------------------------
"bambinos83" <[email protected]> a
écrit dans le message de
news:[email protected]...

 

[bambinos83]

once again, many thanks. You just saved me a LOT of time!!

thank