copy range to diffrent book

[mercmannick]

Set wkbkZF = Workbooks("ZF17.5.xls")

Set MyRange = wkbkZF.Sheets(1).Range("B3:M" & Cells(Rows.Count, 2).End(xlUp).Row)
MyRange.Copy Destination:=wkbkSS.Sheets("Everything").Range("B3")

can anyone see why this is only copying first 2 rows data only

Thanks

Merc :banghead:

[mdmackillop]

Hi Merc,
You are not qualifying this part,
Cells(Rows.Count, 2).End(xlUp).Row)

which will be getting its value from the active sheet.
try
Set MyRange = wkbkZF.Sheets(1).Range("B3:M" & wkbkZF.Sheets(1).Cells(Rows.Count, 2).End(xlUp).Row)
then tidy it up using a With statement.

[mercmannick]

md
thanks i couldnt see where i was going wrong, one more little thing , when i have pasted data , is there an easy way to centre text, bold text and border text

Thanks

Merc

[mdmackillop]

Change the names to suit
Sub trial()

Set wkbkZF = Workbooks("Test2.xls")
Set wkbkSS = Workbooks("Test.xls")

Set tgt = wkbkSS.Sheets("Everything").Range("B3")
With wkbkZF.Sheets(1)
Set MyRange = .Range("B3:M" & .Cells(Rows.Count, 2).End(xlUp).Row)
End With
MyRange.Copy Destination:=tgt
With tgt.CurrentRegion
.HorizontalAlignment = xlCenter
.Font.Bold = True
.Borders().LineStyle = xlContinuous
End With
End Sub

[mercmannick]

mdmackillop

superb thank you :friends:

now i just have this little task left hehe

everything sheet
Auto filter col G begins with S3 or 48 all B3 down paste to B3 "internal" page
Auto filter sched start column date out to next Monday interiorcolour black and font white
Internal page data sort by col D , col F ascending , col B descending






everything sheet
Auto filter rec store begins with 05, copy all B3 down paste to external page B3, Auto filter col B date out to week today black cell and font white
external page data sort by col D , col F ascending , col B descending

col A A3 down to end data sequential number rows



thanks
Merc

[mdmackillop]

Can you post Everything sheet and a copy to show what you're after?

[mercmannick]

mdmackillop

attached book and results thanks

Merc

[mercmannick]

Option Explicit
Private ws As Worksheet
Private Sub Stage_Starts_Sheets()
Dim LstRowEx, LstRowIn, LstRowEvry, iLastRow As Long
Dim wkbkSS, wkbkZF As Workbook
Dim shEX, shIN, shEV, shS70, shtReport As Worksheet
Dim ws As Worksheet
Dim cell, MyRange, tgt As Range

On Error GoTo ErrorHandler
'wkbkSS = "IMF stage starts wk " & CStr(VBAWeekNum(Now(), 1))
'wkbkSS = wkbkSS & "." & CStr(Application.WorksheetFunction.Weekday(Now())) - 2 & ".xls"
wkbkSS = "IMF stage starts Template"
wkbkSS = "C:\Detail Shops\Internal Supply - IMF\S95 - Logistics\STAGE START SHORTAGES\" & wkbkSS
Workbooks.Open Filename:=wkbkSS 'define workbook stage starts and open
Set wkbkSS = Workbooks("IMF stage starts Template")
For Each ws In wkbkSS.Worksheets(Array("Everything", "Internal", "External", "S70"))
With ws.Rows("3:" & Rows.Count)
.AutoFilter
.ClearContents
.Interior.ColorIndex = xlNone ' clear contents
End With
Next ws
With wkbkSS.Worksheets("Everything").Range("A1")
.FormulaR1C1 = " IMF stage starts WK " & CStr(VBAWeekNum(Now(), 1)) & "." _
& CStr(Application.WorksheetFunction.Weekday(Now())) - 1
End With
With wkbkSS.Worksheets("Internal").Range("A1")
.FormulaR1C1 = " Internal Stage Starts WK " & CStr(VBAWeekNum(Now(), 1)) & "." _
& CStr(Application.WorksheetFunction.Weekday(Now())) - 1
End With
With wkbkSS.Worksheets("External").Range("A1")
.FormulaR1C1 = " External Kitting WK " & CStr(VBAWeekNum(Now(), 1)) & "." _
& CStr(Application.WorksheetFunction.Weekday(Now())) - 1
End With
With wkbkSS.Worksheets("S70").Range("A1")
.FormulaR1C1 = " IMF stage starts WK " & CStr(VBAWeekNum(Now(), 1)) & "." _
& CStr(Application.WorksheetFunction.Weekday(Now())) - 1
End With
wkbkSS.SaveAs Filename:= _
"C:\Detail Shops\Internal Supply - IMF\S95 - Logistics\STAGE START SHORTAGES\" _
& "IMF stage starts WK " & CStr(VBAWeekNum(Now(), 1)) & "." _
& CStr(Application.WorksheetFunction.Weekday(Now())) - 1 & ".xls" _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False '******save as todays file name
Set wkbkZF = Workbooks("ZF17.5.xls")
Set wkbkSS = Workbooks("IMF stage starts WK " & CStr(VBAWeekNum(Now(), 1)) & "." _
& CStr(Application.WorksheetFunction.Weekday(Now())) - 1 & ".xls")
Set tgt = wkbkSS.Sheets("Everything").Range("B3")
With wkbkZF.Sheets(1)
Set MyRange = .Range("B3:M" & .Cells(Rows.Count, 2).End(xlUp).Row)
End With
MyRange.Copy Destination:=tgt
With tgt.CurrentRegion
.HorizontalAlignment = xlCenter
.Font.Bold = True
.Borders().LineStyle = xlContinuous
End With
wkbkZF.Close
wkbkSS.Sheets("Everything").Range("A1:I1").HorizontalAlignment = xlLeft
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
Private Sub changecellcolours()
Dim wkbkSS, wkbkZF As Workbook
Dim Rng As Range, r As Long, x As Long
Set wkbkSS = Workbooks("IMF stage starts WK " & CStr(VBAWeekNum(Now(), 1)) & "." _
& CStr(Application.WorksheetFunction.Weekday(Now())) - 1 & ".xls")
Set ws = wkbkSS.Sheets("Everything")
For x = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row To 3 Step -1 '***set coumn 4 as range
With ws.Cells(x, 10)
Select Case Left(.Value, 2)
Case "S0" '***change current workcentre colours
.Interior.ColorIndex = 3
Case "S1" '***change current workcentre colours
.Interior.ColorIndex = 27
Case "S4" '***change current workcentre colours
.Interior.ColorIndex = 35
Case "S7" '***current workcentre colours
.Interior.ColorIndex = 45
Case "20" '***change current workcentre colours
.Interior.ColorIndex = 8
Case Else
'do nothing
End Select
End With
Next x
End Sub
Public Sub ToggleEvents(blnState As Boolean)
'// Written by Zack Barresse, aka firefytr
With Application
.DisplayAlerts = blnState
.EnableEvents = blnState
.ScreenUpdating = blnState
If blnState = True Then
.StatusBar = False
End If
End With
End Sub
Private Sub Remove_T_L_M()
Dim r As Long, Rng As Range, x As Long
Set ws = Sheets("ZF17.4")
Range("5:5").EntireRow.Delete
For x = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row To 3 Step -1 '***set coumn 4 as range
With ws.Cells(x, 3)
Select Case Left(.Value, 1)
Case "L", "T", "M" '***clear l,T,m prefix from column 3
.EntireRow.Delete
Case Else
'do nothing
End Select
End With
Next x
End Sub
Private Sub SetDate()
Dim strFileName As String
Set ws = Sheets("ZF17.4")
ws.Range("B:B").Replace What:=".", Replacement:="/", LookAt:=xlPart
End Sub
Private Sub CHANGE_MRP()
Dim iLastRow As Long, Rng As Range, r As Long, x As Long
Set ws = Sheets("ZF17.4")
For x = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row To 4 Step -1 '***set coumn 4 as range
With ws.Cells(x, 4)
Select Case Left(.Value, 2)
Case "B0" '***change mrp codes
.Value = "S70"
Case "B1" '***change mrp codes
.Value = "S17"
Case "S1" '***change mrp codes
.Value = "S40"
Case "I0", "I1", "I2", "I3" '***change mrp codes
.Value = "S03C"
Case "I4" '***change mrp codes
.Value = "S03E"
Case "I5" '***change mrp codes
.Value = "S03F"
Case "I6" '***change mrp codes
.Value = "S03W"
Case "I7", "I8", "I9" '***change mrp codes
.Value = "S03G"
Case Else
'do nothing
End Select
End With
Next x
End Sub
Private Sub Delete_Blank_PO()
Set ws = Sheets("ZF17.4")
If ws.AutoFilterMode = False Then ws.Cells(4, 6).AutoFilter
ws.Range("F5").AutoFilter Field:=5, Criteria1:="="
ws.Range("F5").CurrentRegion.Offset(1, 0).SpecialCells _
(xlCellTypeVisible).EntireRow.Delete
ws.AutoFilterMode = False
End Sub
Private Sub Remove_Planned_or_purch()
Dim r As Long
Dim Rng As Range
Dim x&
Set ws = Sheets("ZF17.4")
For x = Cells(Rows.Count, 2).End(xlUp).Row To 5 Step -1 '***set coumn 12 as range
With Cells(x, 6)
Select Case Left(.Value, 1)
Case "p", "P" '***clear planned or purchreqs from col 6
.EntireRow.Delete
Case Else
'do nothing
End Select
End With
Next x
End Sub
Private Sub Delete_0_OPs()
Dim iLastRow As Long
Dim Rng, MyRange, cell As Range
Dim r As Long
Dim x&
Set ws = Sheets("ZF17.4")
'Per your code but shouldn't this be rows.Count, 6??
For x = Cells(Rows.Count, 2).End(xlUp).Row To 5 Step -1
'Delete rows where cells in Column outstanding ops are blank
If Cells(x, 12).Value = 0 Then
Cells(x, 12).EntireRow.Delete
End If
Next x
With ws.Range("B5:M" & Cells(Rows.Count, 2).End(xlUp).Row)
.Sort _
Key1:=Range("D5"), _
Key2:=Range("B5")
End With
FilterDelete (ActiveSheet.Range("F5"))
FilterDelete (ActiveSheet.Range("C5"))
End Sub
Sub zflex()
Call ToggleEvents(False)
Call Remove_T_L_M
Call SetDate
Call CHANGE_MRP
Call Delete_Blank_PO
Call Remove_Planned_or_purch
Call Delete_0_OPs
Call Stage_Starts_Sheets
Call changecellcolours
Call ToggleEvents(True)
End Sub
Function FilterDelete(TargetColumn As Range)
'Author : Ken Puls (www.excelguru.ca)
'Macro Purpose: To quickly eliminate duplicates from specified column
' Intended for use with data lists with/without header information

Dim lLastRow As Long
Dim lLastCol As Long

'Check if multiple columns provided and exit if so
If TargetColumn.Columns.Count <> 1 Then Exit Function

With TargetColumn.Parent
'Determine last row and last column
lLastRow = .Cells.Find(What:="*", After:=.Range("A1"), LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
lLastCol = .Cells.Find(What:="*", After:=.Range("A1"), LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

'Set up an index column of ascending numbers after the last column
.Cells(1, lLastCol + 1).Value = 1
.Range(.Cells(2, lLastCol + 1), .Cells(lLastRow, lLastCol + 1)).FormulaR1C1 = "=R[-1]C+1"
.Columns(lLastCol + 1).Cells.Copy
.Columns(lLastCol + 1).Cells.PasteSpecial Paste:=xlValues

'Sort the records by the column specified in ascending order
.Range(.Cells(1, 1), .Cells(lLastRow, lLastCol + 1)).Sort _
Key1:=TargetColumn, Order1:=xlAscending, _
Key2:=.Columns(lLastCol + 1)

'Set up an formula column at end to determine if each rows record matches
'the previous rows record. If so, mark it 0, otherwise 1
.Cells(1, lLastCol + 2).Value = 0
.Range(.Cells(2, lLastCol + 2), .Cells(lLastRow, lLastCol + 2)).FormulaR1C1 = _
"=if(RC[" & TargetColumn.Column - (lLastCol + 2) & "]=R[-1]C[" & TargetColumn.Column - (lLastCol + 2) & "],1,0)"
.Columns(lLastCol + 2).Cells.Copy
.Columns(lLastCol + 2).Cells.PasteSpecial Paste:=xlValues

'Sort the records by the match column. Eliminates complex rangs in large data sets that create errors
.Range(.Cells(1, 1), .Cells(lLastRow, lLastCol + 2)).Sort _
Key1:=.Cells(1, lLastCol + 2)

'Autofilter and delete all cells showing a 1 as they are duplicate values
With .Range(.Cells(1, 1), (.Cells(lLastRow, lLastCol + 2)))
.AutoFilter
.AutoFilter Field:=lLastCol + 2, Criteria1:="1"
End With
.Range(.Cells(2, 1), .Cells(lLastRow, lLastCol + 2)).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilterMode = False

'Resort the data back to the original order
.Range(.Cells(1, 1), .Cells(.Rows.Count, lLastCol + 2).End(xlUp)).Sort _
Key1:=.Cells(1, lLastCol + 1)

'Remove index columns created for duplicate removal
.Range(.Cells(1, lLastCol + 1), .Cells(1, lLastCol + 2)).EntireColumn.Delete
End With

End Function

here is all the code im usin so far and ZF file

Merc

[mercmannick]

anyone hlep me finish off last bit of this project , or point me in right direction

Thanks

Merc

[mercmannick]

Sub Macro1()
'
' Macro1 Macro
'

'
Range("B2").Select
Selection.AutoFilter
ActiveSheet.Range("$A$2:$M$404").AutoFilter Field:=7, Criteria1:="=05*", _
Operator:=xlOr, Criteria2:="=48*"
Range("B3").Select
Range(Selection, Selection.End(xlDown)).Select
Range("B3:M395").Select
Selection.Copy
Sheets("External").Select
Range("B3").Select
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=-15
Range("E2").Select
Application.CutCopyMode = False
Selection.AutoFilter
ActiveSheet.Range("$A$2:$N$114").AutoFilter Field:=2, Criteria1:=Array( _
"13/04/2007", "16/04/2007"), Operator:=xlFilterValues, Criteria2:=Array(0, _
"12/4/2007")
Range("B3:B91").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight1
.TintAndShade = 4.99893185216834E-02
.PatternTintAndShade = 0
End With
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight1
.TintAndShade = 4.99893185216834E-02
.PatternTintAndShade = 0
End With
Range("C7").Select
ActiveSheet.Range("$A$2:$N$114").AutoFilter Field:=2
Range("A3").Select
ActiveCell.FormulaR1C1 = "1"
Range("A4").Select
ActiveCell.FormulaR1C1 = "2"
Range("A5").Select
ActiveCell.FormulaR1C1 = "3"
Range("A6").Select
ActiveCell.FormulaR1C1 = "4"
Range("A7").Select
ActiveCell.FormulaR1C1 = "5"
Range("A8").Select
ActiveCell.FormulaR1C1 = "6"
Range("A6:A8").Select
Selection.AutoFill Destination:=Range("A6:A114")
Range("A6:A114").Select
End Sub

here is recorded code of what i need to do , any help would be appreciated

Thanks

Merc