Help to complete a code

[atmakefka]

Hello
I'm sorry but I don't speak english very well
I want you to help me to complete a code


I have this 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

[Bob Phillips]

Here is an amended routine.

call like Extract "gabri012"

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

[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

[Bob Phillips]

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.

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

[atmakefka]

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

[Bob Phillips]

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

[atmakefka]

"argument ByRef incompatible"

[Bob Phillips]

Sorry, my error

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

[atmakefka]

thanks !!

[atmakefka]

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 :



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

[Bob Phillips]

Can we just use worksheet formulae for this?

[atmakefka]

no, it must be a macro

[Bob Phillips]

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

[atmakefka]

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

[Bob Phillips]

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.

[atmakefka]

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

thanks !

[Bob Phillips]

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

[atmakefka]

woow gg ! thanks for all !

[atmakefka]

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

[Bob Phillips]

I need juste to separate in two codes

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