Can anyone figure out why one sheet acts differently that another?

P

peterrudge

New Member
Joined
Nov 6, 2011
Messages
17
I am using a macro to create a cutlist from an excel workbook. There are four sheets in the work book. There is a paste special command that runs on each sheet. On two of the sheets the command returns values only in cells that are not empty. On the other two sheets all the empty cells are filled with zeros. I can't figure out how to keep the empty cells from being filled with zeros. Can you help?

Sample Excel Doc I am trying to use macro on

Macro I am trying to execute:
Code: 
Sub CutlistCM()
'
' UnfinishedPartsCutlistCM Macro
' Unfinished parts cultist. Units CM
'

'
    
    ActiveSheet.Name = "Unfinished Parts Units CM"
    Sheets.Add After:=Sheets(Sheets.Count)
    Sheets.Add After:=Sheets(Sheets.Count)
    Sheets("Sheet1").Select
    Sheets("Sheet1").Name = "Finished Parts Units CM"
    Sheets("Sheet2").Select
    Sheets("Sheet2").Name = "Faces Units CM"
    Sheets.Add After:=Sheets(Sheets.Count)
    Sheets("Sheet3").Select
    Sheets("Sheet3").Name = "Order Units CM"


    
'
'Change names of columns to work with move routine below
'
    Sheets("Unfinished Parts Units CM").Select
    Rows("1:1").Select
    Selection.Replace What:="PATH", Replacement:="-PART-", LookAt:=xlWhole, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="RIP", Replacement:="-RIP-", LookAt:=xlWhole, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="XCUT", Replacement:="-XCUT-", LookAt:=xlWhole, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="MATERIAL", Replacement:="-MATERIAL-", LookAt:= _
        xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="NOTES", Replacement:="-NOTES-", LookAt:= _
        xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="W_ORDER", Replacement:="-ORDER-", LookAt:= _
        xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="Z_CUTLIST", Replacement:="-CUTLIST-", LookAt:= _
        xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

    
'
'Move columns to correct order
'
    

    Dim aCols() As Variant, z As Long, iColCnt As Long
    Dim rFind As Range, rLook As Range
    aCols = Array("-PART-", "-RIP-", "-XCUT-", "-MATERIAL-", "-NOTES-", "-ORDER-", "-CUTLIST-")
    Set rLook = ActiveSheet.Range("1:1")
    For z = LBound(aCols) To UBound(aCols)
        Set rFind = rLook.Find(What:=aCols(z))
        If Not rFind Is Nothing Then
            If ActiveSheet.Columns(z + 1).Address <> rFind.EntireColumn.Address Then
                rFind.EntireColumn.Cut
                ActiveSheet.Columns(z + 1).Insert
            End If
        End If
    Next z
    Application.CutCopyMode = False
    
'
'Copy entire contents to all sheets
'

    Sheets("Unfinished Parts Units CM").Select
    Range("A1:BW52").Select
    Selection.Copy
    Sheets("Finished Parts Units CM").Select
    ActiveSheet.Paste
    Sheets("Faces Units CM").Select
    ActiveSheet.Paste
    Sheets("Order Units CM").Select
    ActiveSheet.Paste
    


    
'
'Filter the rows we want on each sheet
'

    Sheets("Unfinished Parts Units CM").Select
    Cells.Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$BZ$132").AutoFilter Field:=7, Criteria1:="Yes"
    ActiveSheet.Range("$A$1:$BZ$132").AutoFilter Field:=4, Criteria1:= _
        "=1/4 Int Material", Operator:=xlOr, Criteria2:="=3/4 Int Material"
        
    Sheets("Finished Parts Units CM").Select
    Cells.Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$BZ$132").AutoFilter Field:=7, Criteria1:="Yes"
    ActiveSheet.Range("$A$1:$BZ$132").AutoFilter Field:=4, Criteria1:= _
        "=1/4 Ext Material", Operator:=xlOr, Criteria2:="=3/4 Ext Material"
        
    Sheets("Faces Units CM").Select
    Cells.Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$BZ$132").AutoFilter Field:=7, Criteria1:="Yes"
    ActiveSheet.Range("$A$1:$BZ$132").AutoFilter Field:=4, Criteria1:= _
        "=Faces"
        
    Sheets("Order Units CM").Select
    Cells.Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$BZ$132").AutoFilter Field:=6, Criteria1:= _
        "=Yes"
        
'
'Delete hidden rows and columns
'
Sheets("Unfinished Parts Units CM").Select
For lp = 256 To 1 Step -1 'loop through all columns
If Columns(lp).EntireColumn.Hidden = True Then Columns(lp).EntireColumn.Delete Else
Next

For lp = 65536 To 1 Step -1 'loop through all rows
If Rows(lp).EntireRow.Hidden = True Then Rows(lp).EntireRow.Delete Else
Next

Sheets("Finished Parts Units CM").Select
For lp = 256 To 1 Step -1 'loop through all columns
If Columns(lp).EntireColumn.Hidden = True Then Columns(lp).EntireColumn.Delete Else
Next

For lp = 65536 To 1 Step -1 'loop through all rows
If Rows(lp).EntireRow.Hidden = True Then Rows(lp).EntireRow.Delete Else
Next

Sheets("Faces Units CM").Select
For lp = 256 To 1 Step -1 'loop through all columns
If Columns(lp).EntireColumn.Hidden = True Then Columns(lp).EntireColumn.Delete Else
Next

For lp = 65536 To 1 Step -1 'loop through all rows
If Rows(lp).EntireRow.Hidden = True Then Rows(lp).EntireRow.Delete Else
Next

Sheets("Order Units CM").Select
For lp = 256 To 1 Step -1 'loop through all columns
If Columns(lp).EntireColumn.Hidden = True Then Columns(lp).EntireColumn.Delete Else
Next

For lp = 65536 To 1 Step -1 'loop through all rows
If Rows(lp).EntireRow.Hidden = True Then Rows(lp).EntireRow.Delete Else
Next

'
'Delete columns we don't need
'

Sheets("Unfinished Parts Units CM").Select
Columns("E:BZ").Select
    Selection.Delete Shift:=xlToLeft
    
Sheets("Finished Parts Units CM").Select
Columns("E:BZ").Select
    Selection.Delete Shift:=xlToLeft
    
Sheets("Faces Units CM").Select
Columns("F:BZ").Select
    Selection.Delete Shift:=xlToLeft
    
Sheets("Order Units CM").Select
Columns("F:BZ").Select
    Selection.Delete Shift:=xlToLeft
    
'
'Change values to CM
'
Sheets("Unfinished Parts Units CM").Select
 Range("H1").Select
 ActiveCell.FormulaR1C1 = "2.54"
    Range("H1").Select
    Selection.Copy
    Range("B2:C2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveWindow.SmallScroll Down:=-3
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _
        SkipBlanks:=True, Transpose:=False
    Application.CutCopyMode = False
    Selection.NumberFormat = "0.0"
    Range("H1").Select
    ActiveCell.FormulaR1C1 = ""
    
Sheets("Finished Parts Units CM").Select
 Range("H1").Select
 ActiveCell.FormulaR1C1 = "2.54"
    Range("H1").Select
    Selection.Copy
    Range("B2:C2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveWindow.SmallScroll Down:=-3
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _
        SkipBlanks:=True, Transpose:=False
    Application.CutCopyMode = False
    Selection.NumberFormat = "0.0"
    Range("H1").Select
    ActiveCell.FormulaR1C1 = ""
    
Sheets("Faces Units CM").Select
 Range("H1").Select
 ActiveCell.FormulaR1C1 = "2.54"
    Range("H1").Select
    Selection.Copy
    Range("B2:C2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveWindow.SmallScroll Down:=-3
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _
        SkipBlanks:=True, Transpose:=False
    Application.CutCopyMode = False
    Selection.NumberFormat = "0.0"
    Range("H1").Select
    ActiveCell.FormulaR1C1 = ""
    
Sheets("Order Units CM").Select
 Range("H1").Select
 ActiveCell.FormulaR1C1 = "2.54"
    Range("H1").Select
    Selection.Copy
    Range("B2:C2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveWindow.SmallScroll Down:=-3
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _
        SkipBlanks:=True, Transpose:=False
    Application.CutCopyMode = False
    Selection.NumberFormat = "0.0"
    Range("H1").Select
    ActiveCell.FormulaR1C1 = ""
    
'
'Sort by material, rip, then xcut
'

Sheets("Unfinished Parts Units CM").Select
 Range("A1:G1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveWorkbook.Worksheets("Unfinished Parts Units CM").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Unfinished Parts Units CM").Sort.SortFields.Add Key _
        :=Range("D2:D132"), SortOn:=xlSortOnValues, Order:=xlDescending, _
        DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Unfinished Parts Units CM").Sort.SortFields.Add Key _
        :=Range("B2:B132"), SortOn:=xlSortOnValues, Order:=xlDescending, _
        DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Unfinished Parts Units CM").Sort.SortFields.Add Key _
        :=Range("C2:C132"), SortOn:=xlSortOnValues, Order:=xlDescending, _
        DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Unfinished Parts Units CM").Sort
        .SetRange Range("A1:G132")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
Sheets("Finished Parts Units CM").Select
 Range("A1:G1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveWorkbook.Worksheets("Unfinished Parts Units CM").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Unfinished Parts Units CM").Sort.SortFields.Add Key _
        :=Range("D2:D132"), SortOn:=xlSortOnValues, Order:=xlDescending, _
        DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Unfinished Parts Units CM").Sort.SortFields.Add Key _
        :=Range("B2:B132"), SortOn:=xlSortOnValues, Order:=xlDescending, _
        DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Unfinished Parts Units CM").Sort.SortFields.Add Key _
        :=Range("C2:C132"), SortOn:=xlSortOnValues, Order:=xlDescending, _
        DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Unfinished Parts Units CM").Sort
        .SetRange Range("A1:G132")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

Sheets("Faces Units CM").Select
 Range("A1:G1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveWorkbook.Worksheets("Unfinished Parts Units CM").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Unfinished Parts Units CM").Sort.SortFields.Add Key _
        :=Range("D2:D132"), SortOn:=xlSortOnValues, Order:=xlDescending, _
        DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Unfinished Parts Units CM").Sort.SortFields.Add Key _
        :=Range("B2:B132"), SortOn:=xlSortOnValues, Order:=xlDescending, _
        DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Unfinished Parts Units CM").Sort.SortFields.Add Key _
        :=Range("C2:C132"), SortOn:=xlSortOnValues, Order:=xlDescending, _
        DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Unfinished Parts Units CM").Sort
        .SetRange Range("A1:G132")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

Sheets("Order Units CM").Select
 Range("A1:G1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveWorkbook.Worksheets("Unfinished Parts Units CM").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Unfinished Parts Units CM").Sort.SortFields.Add Key _
        :=Range("D2:D132"), SortOn:=xlSortOnValues, Order:=xlDescending, _
        DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Unfinished Parts Units CM").Sort.SortFields.Add Key _
        :=Range("B2:B132"), SortOn:=xlSortOnValues, Order:=xlDescending, _
        DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Unfinished Parts Units CM").Sort.SortFields.Add Key _
        :=Range("C2:C132"), SortOn:=xlSortOnValues, Order:=xlDescending, _
        DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Unfinished Parts Units CM").Sort
        .SetRange Range("A1:G132")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
Call BlankRowUnfin
Call BlankRowFin
Call SumRIPRowsUnFin
Call SumRIPRowsFin
Call Formatting


End Sub

    
'
'Add a blank row when the RIP value changes
'

Sub BlankRowUnfin()
Sheets("Unfinished Parts Units CM").Select
    Dim lRow As Long
    For lRow = Cells(Cells.Rows.Count, "B").End(xlUp).Row To 2 Step -1
        If Cells(lRow, "B") <> Cells(lRow - 1, "B") Then Rows(lRow).EntireRow.Insert
    Next lRow
End Sub

Sub BlankRowFin()
Sheets("Finished Parts Units CM").Select
    Dim lRow As Long
    For lRow = Cells(Cells.Rows.Count, "B").End(xlUp).Row To 2 Step -1
        If Cells(lRow, "B") <> Cells(lRow - 1, "B") Then Rows(lRow).EntireRow.Insert
    Next lRow
End Sub

Sub SumRIPRowsUnFin()
    
'
'Sum RIP rows
'
Sheets("Unfinished Parts Units CM").Select
Dim StartRow As Integer
Dim EndRow As Integer

StartRow = 3
EndRow = Range("D65536").End(xlUp).Offset(1, 0).Row
For i = StartRow To EndRow
If Cells(i, "C") = "" And i > StartRow Then
Cells(i, "C").Formula = "=SUM(C" & StartRow & ":C" & i - 1 & ")/244"
Cells(i, "D").Formula = "Rips"
StartRow = i + 1
End If
Next

End Sub

Sub SumRIPRowsFin()
Sheets("Finished Parts Units CM").Select
Dim StartRow As Integer
Dim EndRow As Integer

StartRow = 3
EndRow = Range("D65536").End(xlUp).Offset(1, 0).Row
For i = StartRow To EndRow
If Cells(i, "C") = "" And i > StartRow Then
Cells(i, "C").Formula = "=SUM(C" & StartRow & ":C" & i - 1 & ")/244"
Cells(i, "D").Formula = "Rips"
StartRow = i + 1
End If
Next

End Sub


Sub Formatting()


'
'Remove extra words in PART column and format RIP and XCUT for easier reading
'
Sheets("Unfinished Parts Units CM").Select
    Cells.Select
    Selection.Replace What:="Model*/WorkPort*/", Replacement:="", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Range("A1").Select
    Columns("A:A").ColumnWidth = 19.43
    Columns("B:C").Select
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
Sheets("Finished Parts Units CM").Select
    Cells.Select
    Selection.Replace What:="Model*/WorkPort*/", Replacement:="", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Range("A1").Select
    Columns("A:A").ColumnWidth = 19.43
    Columns("B:C").Select
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
Sheets("Faces Units CM").Select
    Cells.Select
    Selection.Replace What:="Model*/WorkPort*/", Replacement:="", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Range("A1").Select
    Columns("A:A").ColumnWidth = 19.43
    Columns("B:C").Select
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
Sheets("Order Units CM").Select
    Cells.Select
    Selection.Replace What:="Model*/WorkPort*/", Replacement:="", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Range("A1").Select
    Columns("A:A").ColumnWidth = 19.43
    Columns("B:C").Select
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
    
'
'Add some lines to help highlight rips totals
'
Sheets("Unfinished Parts Units CM").Select
Cells.Select
    Selection.FormatConditions.Add Type:=xlTextString, String:="Rips", _
        TextOperator:=xlContains
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Borders(xlTop)
        .LineStyle = xlContinuous
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.FormatConditions(1).Borders(xlBottom)
        .LineStyle = xlContinuous
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    
    
Sheets("Finished Parts Units CM").Select
Cells.Select
    Selection.FormatConditions.Add Type:=xlTextString, String:="Rips", _
        TextOperator:=xlContains
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Borders(xlTop)
        .LineStyle = xlContinuous
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.FormatConditions(1).Borders(xlBottom)
        .LineStyle = xlContinuous
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    

'
'Change page settings to show file name and sheet name as headers / footers. Printer header on all pages
'
Sheets("Unfinished Parts Units CM").Select
 With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$1"
    End With
    With ActiveSheet.PageSetup
        .CenterHeader = "&F"
        .CenterFooter = "&A"
    End With
    
Sheets("Finished Parts Units CM").Select
 With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$1"
    End With
    With ActiveSheet.PageSetup
        .CenterHeader = "&F"
        .CenterFooter = "&A"
    End With
    
Sheets("Faces Units CM").Select
 With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$1"
    End With
    With ActiveSheet.PageSetup
        .CenterHeader = "&F"
        .CenterFooter = "&A"
    End With
    
Sheets("Order Units CM").Select
 With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$1"
    End With
    With ActiveSheet.PageSetup
        .CenterHeader = "&F"
        .CenterFooter = "&A"
    End With
    
End Sub
 

Excel Facts

Who is Mr Spreadsheet?
Author John Walkenbach was Mr Spreadsheet until his retirement in June 2019.
Sort by date Sort by votes
You have a lot of "selecting" and activating and you keep going back and forth the sheets. Recommendations:

1) Run the autofilter from the original data sheets and copy only the needed data into each new sheet.

2) Do the formatting/editing of the sheets with as few "trips" to the sheets as possible.

This version replaces all your other subs merging them all into one and doing it fewer trips around the block, so to speak.

Code: 
Option Explicit

Sub CutlistCM()
Dim aCols() As Variant, Old() As Variant
Dim StartRow As Long, EndRow As Long, z As Long
Dim rFind As Range, rLook As Range, wsData As Worksheet, ws As Worksheet

Application.ScreenUpdating = False

    Old = Array("PATH", "RIP", "XCUT", "MATERIAL", "NOTES", "W_ORDER", "Z_CUTLIST")
    aCols = Array("-PART-", "-RIP-", "-XCUT-", "-MATERIAL-", "-NOTES-", "-ORDER-", "-CUTLIST-")
        
    Set wsData = ActiveSheet
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Unfinished Parts Units CM"
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Finished Parts Units CM"
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Faces Units CM"
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Order Units CM"
    
'Change names of columns to work with move routine below
    With wsData
        For z = LBound(Old) To UBound(Old)
            .Rows("1:1").Replace What:=Old(z), Replacement:=aCols(z), _
                LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, _
                SearchFormat:=False, ReplaceFormat:=False
        Next z

    'Move columns to correct order
        Set rLook = .Range("1:1")
        For z = LBound(aCols) To UBound(aCols)
            Set rFind = rLook.Find(What:=aCols(z), LookIn:=xlValues, LookAt:=xlWhole)
            If Not rFind Is Nothing Then
                If .Columns(z + 1).Address <> rFind.EntireColumn.Address Then
                    rFind.EntireColumn.Cut
                    .Columns(z + 1).Insert
                End If
            End If
        Next z
        Application.CutCopyMode = False
        
    'correct values in CM
        .Range("H1") = "2.54"
        .Range("H1").Copy
        With .Range("B:C")
            .PasteSpecial xlPasteAll, Operation:=xlMultiply, _
                SkipBlanks:=True, Transpose:=False
            .NumberFormat = "0.0"
        End With
        .Range("H1") = ""
        
    'Filter from the original datasheet
        .Rows(1).AutoFilter
      'Filter for UNFINISHED PARTS
        .Rows(1).AutoFilter Field:=7, Criteria1:="Yes"
        .Rows(1).AutoFilter Field:=4, Criteria1:="=1/4 Int Material", _
                      Operator:=xlOr, Criteria2:="=3/4 Int Material"
        .Range("A1:D52").Copy Sheets("Unfinished Parts Units CM").Range("A1")
        .ShowAllData
        
      'Filter for FINISHED PARTS
        .Rows(1).AutoFilter Field:=7, Criteria1:="Yes"
        .Rows(1).AutoFilter Field:=4, Criteria1:="=1/4 Int Material", _
                      Operator:=xlOr, Criteria2:="=3/4 Int Material"
        .Range("A1:D52").Copy Sheets("Finished Parts Units CM").Range("A1")
        .ShowAllData
        
      'Filter for FACES UNITS
        .Rows(1).AutoFilter Field:=7, Criteria1:="Yes"
        .Rows(1).AutoFilter Field:=4, Criteria1:="=Faces"
        .Range("A1:E52").Copy Sheets("Faces Units CM").Range("A1")
        .ShowAllData
        
      'Filter for ORDER UNITS
        .Rows(1).AutoFilter Field:=6, Criteria1:="=Yes"
        .Range("A1:E52").Copy Sheets("Order Units CM").Range("A1")
        .AutoFilterMode = False
    End With
    
'Sort by material, rip, then xcut, then remove extra text, set print settings
    For Each ws In Sheets(Array("Unfinished Parts Units CM", _
            "Finished Parts Units CM", "Faces Units CM", "Order Units CM"))
        With ws
            .Range("A:G").Sort Key1:=.Range("D2"), Order1:=xlAscending, _
                      Key2:=.Range("B2"), Order2:=xlAscending, _
                      Key3:=.Range("C2"), Order3:=xlAscending, _
                      Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
                      Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, _
                      DataOption2:=xlSortNormal, DataOption3:=xlSortNormal
        
            .Cells.Replace What:="Model*/WorkPort*/", Replacement:="", LookAt:=xlPart, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
            .Columns.AutoFit
            .Columns("B:C").HorizontalAlignment = xlLeft
            
            .PageSetup.PrintTitleRows = "$1:$1"
            .PageSetup.CenterHeader = "&F"
            .PageSetup.CenterFooter = "&A"
        End With
    Next ws
    
    For Each ws In Sheets(Array("Unfinished Parts Units CM", "Finished Parts Units CM"))
        With ws
            For z = .Cells(.Cells.Rows.Count, "B").End(xlUp).Row To 3 Step -1
                If .Cells(z, "B") <> .Cells(z - 1, "B") Then .Rows(z).EntireRow.Insert
            Next z
            .Columns.AutoFit
            
            StartRow = 2
            EndRow = .Range("D" & .Rows.Count).End(xlUp).Row + 1
            For z = StartRow To EndRow
                If .Cells(z, "C") = "" And z > StartRow Then
                    .Cells(z, "C").Formula = "=SUM(C" & StartRow & ":C" & z - 1 & ")/244"
                    StartRow = z + 1
                End If
            Next z
            With .Range("D2:D" & EndRow).SpecialCells(xlBlanks)
                .Borders(xlTop).Weight = xlThin
                .Borders(xlBottom).Weight = xlThin
                .Value = "Rips"
            End With
        End With
    Next ws

Application.ScreenUpdating = True
If MsgBox("Done... do you wish to delete the original raw data sheet?", vbYesNo, _
    "Delete raw data file") = vbYes Then
        Application.DisplayAlerts = False
        wsData.Delete
End If

End Sub
 
Upvote 0
Thank you! Your macro looks so much cleaner than what I put together. That was my first macro and it is pieced together from internet searches. You have been a great help!
 
Upvote 0
This will take care of that, changes noted in red:
Rich (BB code): 
Option Explicit

Sub CutlistCM()
Dim aCols() As Variant, Old() As Variant
Dim StartRow As Long, EndRow As Long, z As Long
Dim rFind As Range, rLook As Range, wsData As Worksheet, ws As Worksheet

Application.ScreenUpdating = False

    Old = Array("PATH", "RIP", "XCUT", "MATERIAL", "NOTES", "W_ORDER", "Z_CUTLIST")
    aCols = Array("-PART-", "-RIP-", "-XCUT-", "-MATERIAL-", "-NOTES-", "-ORDER-", "-CUTLIST-")
        
    Set wsData = ActiveSheet
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Unfinished Parts Units CM"
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Finished Parts Units CM"
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Faces Units CM"
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Order Units CM"
    
'Change names of columns to work with move routine below
    With wsData
        For z = LBound(Old) To UBound(Old)
            .Rows("1:1").Replace What:=Old(z), Replacement:=aCols(z), _
                LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, _
                SearchFormat:=False, ReplaceFormat:=False
        Next z

    'Move columns to correct order
        Set rLook = .Range("1:1")
        For z = LBound(aCols) To UBound(aCols)
            Set rFind = rLook.Find(What:=aCols(z), LookIn:=xlValues, LookAt:=xlWhole)
            If Not rFind Is Nothing Then
                If .Columns(z + 1).Address <> rFind.EntireColumn.Address Then
                    rFind.EntireColumn.Cut
                    .Columns(z + 1).Insert
                End If
            End If
        Next z
        Application.CutCopyMode = False
        
    'correct values in CM
        .Range("H1") = "2.54"
        .Range("H1").Copy
        With .Range("B:C")
            .PasteSpecial xlPasteAll, Operation:=xlMultiply, _
                SkipBlanks:=True, Transpose:=False
            .NumberFormat = "0.0"
        End With
        .Range("H1") = ""
        
    'Filter from the original datasheet
        .Rows(1).AutoFilter
      'Filter for UNFINISHED PARTS
        .Rows(1).AutoFilter Field:=7, Criteria1:="Yes"
        .Rows(1).AutoFilter Field:=4, Criteria1:="=1/4 Int Material", _
                      Operator:=xlOr, Criteria2:="=3/4 Int Material"
        .Range("A1:D52").Copy Sheets("Unfinished Parts Units CM").Range("A1")
        .ShowAllData
        
      'Filter for FINISHED PARTS
        .Rows(1).AutoFilter Field:=7, Criteria1:="Yes"
        .Rows(1).AutoFilter Field:=4, Criteria1:="=1/4 Int Material", _
                      Operator:=xlOr, Criteria2:="=3/4 Int Material"
        .Range("A1:D52").Copy Sheets("Finished Parts Units CM").Range("A1")
        .ShowAllData
        
      'Filter for FACES UNITS
        .Rows(1).AutoFilter Field:=7, Criteria1:="Yes"
        .Rows(1).AutoFilter Field:=4, Criteria1:="=Faces"
        .Range("A1:E52").Copy Sheets("Faces Units CM").Range("A1")
        .ShowAllData
        
      'Filter for ORDER UNITS
        .Rows(1).AutoFilter Field:=6, Criteria1:="=Yes"
        .Range("A1:E52").Copy Sheets("Order Units CM").Range("A1")
        .AutoFilterMode = False
    End With
    
'Sort by material, rip, then xcut, then remove extra text, set print settings
    For Each ws In Sheets(Array("Unfinished Parts Units CM", _
            "Finished Parts Units CM", "Faces Units CM", "Order Units CM"))
        With ws
            .Range("A:G").Sort Key1:=.Range("D2"), Order1:=xlAscending, _
                      Key2:=.Range("B2"), Order2:=xlAscending, _
                      Key3:=.Range("C2"), Order3:=xlAscending, _
                      Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
                      Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, _
                      DataOption2:=xlSortNormal, DataOption3:=xlSortNormal
        
            .Cells.Replace What:="Model*/WorkPort*/", Replacement:="", LookAt:=xlPart, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
            .Columns.AutoFit
            .Columns("B:C").HorizontalAlignment = xlLeft
            
            .PageSetup.PrintTitleRows = "$1:$1"
            .PageSetup.CenterHeader = "&F"
            .PageSetup.CenterFooter = "&A"
        End With
    Next ws
    
    For Each ws In Sheets(Array("Unfinished Parts Units CM", "Finished Parts Units CM"))
        With ws
            EndRow = .Range("D" & .Rows.Count).End(xlUp).Row
            If EndRow > 1 Then
                For z = EndRow To 3 Step -1
                    If .Cells(z, "B") <> .Cells(z - 1, "B") Then .Rows(z).EntireRow.Insert
                Next z
                .Columns.AutoFit
            
                StartRow = 2
                For z = StartRow To EndRow + 1
                    If .Cells(z, "C") = "" And z > StartRow Then
                        .Cells(z, "C").Formula = "=SUM(C" & StartRow & ":C" & z - 1 & ")/244"
                        StartRow = z + 1
                    End If
                Next z
                With .Range("D2:D" & EndRow).SpecialCells(xlBlanks)
                    .Borders(xlTop).Weight = xlThin
                    .Borders(xlBottom).Weight = xlThin
                    .Value = "Rips"
                End With
            End If
        End With
    Next ws

Application.ScreenUpdating = True
If MsgBox("Done... do you wish to delete the original raw data sheet?", vbYesNo, _
    "Delete raw data file") = vbYes Then
        Application.DisplayAlerts = False
        wsData.Delete
End If

End Sub
 
Upvote 0
It looks like the revised macro causes some unexpected results. When run against another worksheet the differences are very pronounced. There are a lot of values omitted. Does anyone see why jbeaucaire's macro gives different output than the original macro in this post when run against the sample worksheet?

http://dl.dropbox.com/u/30293645/2011-11-06-2.csv
 
Upvote 0
The only notable difference I see is that your data has different PATH strings, so those didn't get simplified down in your new sheet since the paths don't match the replace criteria of the first file. But the results look in line to me.
 
Upvote 0
Spoon feed me here. Since the data is different in the two files, the output would be different. What are you pointing at specifically as the problem?

If it's the missing "final RIPS" row, I see that error. Sorry. Fix this:

Rich (BB code): 
With .Range("D2:D" & EndRow + 1).SpecialCells(xlBlanks)
 
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Solved
Macro to scroll to the last coloured cell in a spreadsheet
Replies
4
Views
376
Joe4
Joe4
E
  • Solved
A little VBA/Macro code adjustment
Replies
3
Views
262
rollis13
rollis13
S
  • Question Question
Help with combining 2 macros into 1
Replies
8
Views
246
MARK858
MARK858
J
  • Question Question
Rename a Sheet
Replies
2
Views
354
Peter_SSs
Peter_SSs
H
  • Solved
Sorting and Deleting VBA for large file
2
Replies
16
Views
766
heathball
H

Forum statistics

Threads
1,223,214
Messages
6,170,774
Members
452,353
Latest member
strainu

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top