is this possible to code this !!!!!!!!!

[mercmannick]

i have a shared workbook on a networked drive,



i would like to be able to grab some specific dat from this file without opening it ?



the data i require though is only identifiable as interior colour red , any other data in this col i would like to ignore,



would like to be able to copy entire row and put in new workbook.



basically this sheet (networked one) i would normally put a autofilter on and on col c pick which section i am looking at at time, ie: workcentres "S17", filter to just these , then look in col j and if it is highlighted red then copy this row to a new workbook and so on,





any help would be appreciated



Merc

 

[mercmannick]

btadams


looks good but unfortunately it is only copying the header row to new workbook

which is wat i want as well just nee the other rows from which is highlighted red


any ideas as which bit to modify to get this going

thanks m8




Tushar

thanks for your advice and yes ,i know wat you mean but this chap who runs this report is very set in his ways (if it aint broke dont fix) attitude but i will try to persuade him round


Regards

Merc

 

[mercmannick]

btadams


sussed it m8 and thank you very much i noticed that your autofilter field was set to 1

and it was field 4

also i have just thought this report changes everyday filename

to week number then day

ie:workbook 30.5.xls

(week 30 day 5)

is there a way round this to pick up newest list created by date created or something


Thanks

Merc

 

[btadams]

try this:

Sub GetRedCells()
Dim strMyBook As String
Dim cell As Range
Dim TempBook As Workbook


   On Error GoTo ErrorHandler

    Application.ScreenUpdating = False
    Set TempBook = Workbooks.Add
    
    'Change line below to suit
    strMyBook = "Workbook " & CStr(VBAWeekNum(Now(), 1))
    strMyBook = strMyBook & "." & CStr(Application.WorksheetFunction.Weekday(Now())) & ".xls"
    strMyBook = Application.InputBox("Enter workbook name", "Get Red Cells", strMyBook, , , , , 2)
    strMyBook = "\\networkserver\users\adamsb\" & strMyBook
    
    Workbooks.Open Filename:=strMyBook
    Range([A1], [IV1].End(xlToLeft)).Copy Destination:=TempBook.Sheets(1).Range("A1")
    
    ' Change Criteria1 to suit
    Range("D:D").AutoFilter Field:=1, Criteria1:="S03B"
    
    For Each cell In Range("E:E").SpecialCells(xlCellTypeVisible)
        If cell.Interior.ColorIndex = 3 Then _
            cell.EntireRow.Copy Destination:=TempBook.Sheets(1).Range("A65536").End(xlUp).Offset(1, 0)
    Next cell
    
    ActiveWorkbook.Close False
    Application.ScreenUpdating = True

   On Error GoTo 0
   Exit Sub

ErrorHandler:

    MsgBox "Error: " & Err.Number & " (" & Err.Description & ")"
End Sub

Function VBAWeekNum(D As Date, FW As Integer) As Integer
     VBAWeekNum = CInt(Format(D, "ww", FW))
End Function

 

[mercmannick]

Btadams


thnx m8

not sure which bit to change on here..............

    'Change line below to suit
    strMyBook = "IMF stage starts wk  " & CStr(VBAWeekNum(Now(), 1))
    strMyBook = strMyBook & "." & CStr(Application.WorksheetFunction.Weekday(Now())) & ".xls"
    strMyBook = Application.InputBox("Enter workbook name", "Get Red Cells", strMyBook, , , , , 2)
   ' strMyBook = "I:\IMF stage starts wk 30.5.xls" & strMyBook

 

[mercmannick]

also on the bit where it says criteria


' Change Criteria1 to suit
Range("D:D").AutoFilter Field:=1, Criteria1:="S03B"


is ther anyway to have inputbox like it is for main file name so people can choose which criteria to pick.........




Regards


Merc

 

[btadams]

try this:

Sub GetRedCells()
Dim strMyBook As String, strFilterBy As String
Dim cell As Range
Dim TempBook As Workbook


   On Error GoTo ErrorHandler

    Application.ScreenUpdating = False
    Set TempBook = Workbooks.Add
    
    'Change line below to suit
    strMyBook = "IMF stage starts wk  " & CStr(VBAWeekNum(Now(), 1))
    strMyBook = strMyBook & "." & CStr(Application.WorksheetFunction.Weekday(Now())) & ".xls"
    strMyBook = Application.InputBox("Enter workbook name", "Get Red Cells", strMyBook, , , , , 2)
    strMyBook = "\\networkserver\users\adamsb\" & strMyBook
    
    Workbooks.Open Filename:=strMyBook
    Range([A1], [IV1].End(xlToLeft)).Copy Destination:=TempBook.Sheets(1).Range("A1")
    
    ' Change Criteria1 to suit
    strFilterBy = Application.InputBox("Enter Filter Criteria", "Get Red Cells", "S03B", , , , , 2)
    Range("D:D").AutoFilter Field:=1, Criteria1:=strFilterBy
    
    For Each cell In Range("E:E").SpecialCells(xlCellTypeVisible)
        If cell.Interior.ColorIndex = 3 Then _
            cell.EntireRow.Copy Destination:=TempBook.Sheets(1).Range("A65536").End(xlUp).Offset(1, 0)
    Next cell
    
    ActiveWorkbook.Close False
    Application.ScreenUpdating = True

   On Error GoTo 0
   Exit Sub

ErrorHandler:

    MsgBox "Error: " & Err.Number & " (" & Err.Description & ")"
End Sub

Function VBAWeekNum(D As Date, FW As Integer) As Integer
     VBAWeekNum = CInt(Format(D, "ww", FW))
End Function

 

[mercmannick]

Bt

Ambiguos name detected :VBAWeekNum

Merc

 

[mercmannick]

sorted BtAdams

Working absolute treat m8 TY

Regards

Merc

PS: will there be any of the lines of code i will need to modify to use on Excel 2000

Testing it on Excel 2003 fine

Once again thanks

 

[btadams]

Should work on either.

 

[btadams]

Just added some coed to stop debug errors that mey accur:

Sub GetRedCells() 
Dim strMyBook As String, strFilterBy As String 
Dim cell As Range, MyRange as Range
Dim TempBook As Workbook 


   On Error GoTo ErrorHandler 

    Application.ScreenUpdating = False 
    Set TempBook = Workbooks.Add 
    
    'Change line below to suit 
    strMyBook = "IMF stage starts wk  " & CStr(VBAWeekNum(Now(), 1)) 
    strMyBook = strMyBook & "." & CStr(Application.WorksheetFunction.Weekday(Now())) & ".xls" 
    strMyBook = Application.InputBox("Enter workbook name", "Get Red Cells", strMyBook, , , , , 2) 
    strMyBook = "\\networkserver\users\adamsb\" & strMyBook 
    
    Workbooks.Open Filename:=strMyBook 
    Range([A1], [IV1].End(xlToLeft)).Copy Destination:=TempBook.Sheets(1).Range("A1") 
    ActiveSheet .ShowAllData
    
    ' Change Criteria1 to suit 
    strFilterBy = Application.InputBox("Enter Filter Criteria", "Get Red Cells", "S03B", , , , , 2) 
    Range("D:D").AutoFilter Field:=1, Criteria1:=strFilterBy 

    if Application.WorksheetFunction.CountA(Range("D:D")) < 2 then
          msgbox "There are no entries for " & strFilterBy 
          exit sub
    end if
    Set MyRange = Range([E2], range("E65536).End(xlup))
    For Each cell In MyRange.SpecialCells(xlCellTypeVisible) 
        If cell.Interior.ColorIndex = 3 Then _ 
            cell.EntireRow.Copy Destination:=TempBook.Sheets(1).Range("A65536").End(xlUp).Offset(1, 0) 
    Next cell 
    
    ActiveWorkbook.Close False 
    Application.ScreenUpdating = True 

   On Error GoTo 0 
   Exit Sub 

ErrorHandler: 

    MsgBox "Error: " & Err.Number & " (" & Err.Description & ")" 
End Sub 

Function VBAWeekNum(D As Date, FW As Integer) As Integer 
     VBAWeekNum = CInt(Format(D, "ww", FW)) 
End Function