Help to complete a code

Hello
I'm sorry but I don't speak english very well
I want you to help me to complete a code
http://img95.echo.cx/img95/6123/sanstitre5yr.jpg

I have this code :

Code:

---

Sub Extract()
  Dim bSheetExists As Boolean 
  Dim iNextRow As Long
  Dim rActivity As Range
  Dim rHeading As Range
  Dim vI As Variant
  Dim vJ As Variant
  Sheets("Data").Activate
  Set rActivity = Range([A2], [A2].End(xlDown))                                                 
  Set rHeading = Rows(1) 
  For Each vI In rActivity 
    bSheetExists = False 
    For Each vJ In Worksheets 
      If vJ.Name = vI.Cells(1, 6) Then                                       
        bSheetExists = True 
        Exit For             
      End If
    Next vJ 
    If bSheetExists Then 
      vJ.Activate           
    Else                                               
      Worksheets.Add After:=Worksheets(Worksheets.Count)                                                         
      ActiveSheet.Name = vI.Cells(1, 6) 
rHeading.Copy ([A1]) 
    End If
    iNextRow = [A1].SpecialCells(xlLastCell).Row + 1 
vI.EntireRow.Copy (Cells(iNextRow, 1))       
Next vI   
End Sub

---

This code take automatically all the lines of the sheet and create a new sheet by user (utilisateur)
But I want it to create a new sheet only for a specified user that I give in a msg box

I hope you'll understand me
Thank you for your help

Here is an amended routine.

call like Extract "gabri012"

Code:

---

Sub Extract(user As String)
Dim bSheetExists As Boolean
Dim iNextRow As Long
Dim rActivity As Range
Dim rHeading As Range
Dim vI As Variant
Dim vJ As Variant
Sheets("Data").Activate
Set rActivity = Range([A2], [A2].End(xlDown))
Set rHeading = Rows(1)
For Each vI In rActivity
If vI.Offset(0, 5).Value = user Then
bSheetExists = False
For Each vJ In Worksheets
If vJ.Name = vI.Cells(1, 6) Then
bSheetExists = True
Exit For
End If
Next vJ
If bSheetExists Then
vJ.Activate
Else
Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = vI.Cells(1, 6)
rHeading.Copy ([A1])
End If
iNextRow = [A1].SpecialCells(xlLastCell).Row + 1
vI.EntireRow.Copy (Cells(iNextRow, 1))
End If
Next vI
End Sub

---

euh..
I need to specify the user in an input box
and extract data in a new sheet only for him
thanks but it doesn't works

Quote:

---

Originally Posted by atmakefka

euh..
I need to specify the user in an input box
and extract data in a new sheet only for him
thanks but it doesn't works

---

It does.

Code:

---

ans = InputBox("Input user name")
    If ans <> "" Then
        Extract ans
    End If

---

Ok, but there's 2 codes ?I'm sorry I don't understand
Could you give me the "full" or unique code ?
thanks

Code:

---

Sub Extract()
ans = InputBox("Input user name")
If ans <> "" Then
ExtractByUser ans
End If
End Sub
 
Sub ExtractByUser(user As String)
Dim bSheetExists As Boolean
Dim iNextRow As Long
Dim rActivity As Range
Dim rHeading As Range
Dim vI As Variant
Dim vJ As Variant
Sheets("Data").Activate
Set rActivity = Range([A2], [A2].End(xlDown))
Set rHeading = Rows(1)
For Each vI In rActivity
If vI.Offset(0, 5).Value = user Then
bSheetExists = False
For Each vJ In Worksheets
If vJ.Name = vI.Cells(1, 6) Then
bSheetExists = True
Exit For
End If
Next vJ
If bSheetExists Then
vJ.Activate
Else
Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = vI.Cells(1, 6)
rHeading.Copy ([A1])
End If
iNextRow = [A1].SpecialCells(xlLastCell).Row + 1
vI.EntireRow.Copy (Cells(iNextRow, 1))
End If
Next vI
End Sub

---

"argument ByRef incompatible"

Sorry, my error

Code:

---

Sub Extract()
Dim ans
ans = InputBox("Input user name")
If ans <> "" Then
ExtractByUser CStr(ans)
End If
End Sub
 
Sub ExtractByUser(user As String)
Dim bSheetExists As Boolean
Dim iNextRow As Long
Dim rActivity As Range
Dim rHeading As Range
Dim vI As Variant
Dim vJ As Variant
Sheets("Data").Activate
Set rActivity = Range([A2], [A2].End(xlDown))
Set rHeading = Rows(1)
For Each vI In rActivity
If vI.Offset(0, 5).Value = user Then
bSheetExists = False
For Each vJ In Worksheets
If vJ.Name = vI.Cells(1, 6) Then
bSheetExists = True
Exit For
End If
Next vJ
If bSheetExists Then
vJ.Activate
Else
Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = vI.Cells(1, 6)
rHeading.Copy ([A1])
End If
iNextRow = [A1].SpecialCells(xlLastCell).Row + 1
vI.EntireRow.Copy (Cells(iNextRow, 1))
End If
Next vI
End Sub

---

thanks !! :):)

I need your help again :/

I have 2 codes to find:

One which caculate the connection time for a specified/given/provided user and period (inputbox^^)

and an another which count the number of sessions opened/connexions for a specified/given/provided user and period, ignoring those under 1 minute during

I have this :

http://img25.echo.cx/img25/9185/13nl.jpg

Column B : The date where the user connected/opened his session
Column D : The date where the user disconnected/closed his session
Column C : The hour he opened
Column E : The hour he closed
Column F : the user/login

I don't know how to do, it seems to be complicated :/
any idea to help me?
thanks

Can we just use worksheet formulae for this?

no, it must be a macro :(

Do you want all of those totals just added to the foot of the new worksheets?

I'm not sure if I had really understood your question
The results must appear in msg box I think

I am suggesting adding them to the sheet for the selected user. More permannent. Post your workbook to give me some valid test data, and I will then post the amendment.

Right :)
Here's a link to the workbook
http://kof54.free.fr/data.xls

thanks ! ;)

Code:

---

Sub Extract()
Dim sName, dteStart, dteEnd
Dim oSheetUser As Worksheet
Dim iNextRow As Long
Dim rActivity As Range
Dim rHeading As Range
Dim vI As Variant
Dim vJ As Variant
Dim iLastRow As Long
Dim sFormula As String
sName = InputBox("Input user name")
If sName = "" Then
Exit Sub
Else
dteStart = InputBox("Input start date")
If dteStart = "" Or Not IsDate(dteStart) Then
Exit Sub
Else
dteEnd = InputBox("Input end date")
If dteEnd = "" Or Not IsDate(dteStart) Then
Exit Sub
End If
End If
End If
Sheets("Data").Activate
Set rActivity = Range([A2], [A2].End(xlDown))
Set rHeading = Rows(1)
On Error Resume Next
Set oSheetUser = Worksheets(sName)
On Error GoTo 0
If oSheetUser Is Nothing Then
Set oSheetUser = Worksheets.Add(After:=Worksheets(Worksheets.Count))
oSheetUser.Name = sName
End If
oSheetUser.Cells.ClearContents
rHeading.Copy oSheetUser.[A1]
iNextRow = 2
For Each vI In rActivity
If vI.Offset(0, 5).Value = sName Then
vI.EntireRow.Copy (oSheetUser.Cells(iNextRow, 1))
iNextRow = iNextRow + 1
End If
Next vI
With oSheetUser
iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
With .Range("A" & iLastRow + 2)
.Value = "Connection time for period " & _
Format(dteStart, "dd mmm yyyy") & " to " & _
Format(dteEnd, "dd mmm yyyy")
sFormula = "=SUMPRODUCT(" & _
"--(B2:B" & iLastRow & ">=--""" & Format(dteStart, "yyyy/mm/dd") & """)," & _
"--(D2:D" & iLastRow & "<=--""" & Format(dteEnd, "yyyy/mm/dd") & """)," & _
"(E2:E" & iLastRow & "-C2:C" & iLastRow & "))"
.Offset(0, 6).Formula = sFormula
.Offset(0, 6).NumberFormat = "[hh]:mm:ss"
.Offset(2, 0).Value = "Connections for period " & _
Format(dteStart, "dd mmm yyyy") & " to " & _
Format(dteEnd, "dd mmm yyyy")
sFormula = "=SUMPRODUCT(" & _
"--(B2:B" & iLastRow & ">=--""" & Format(dteStart, "yyyy/mm/dd") & """)," & _
"--(D2:D" & iLastRow & "<=--""" & Format(dteEnd, "yyyy/mm/dd") & """)," & _
"--((E2:E" & iLastRow & "-C2:C" & iLastRow & ")>=--""00:01:00""))"
.Offset(2, 6).Formula = sFormula
.Offset(2, 6).NumberFormat = "#,##0"
End With
.Activate
End With
End Sub

---

woow gg ! thanks for all !

I need juste to separate in two codes :/
thanks again

Quote:

---

Originally Posted by atmakefka

I need juste to separate in two codes

---

Sorry, can you re-phrase that as I don't understand?