Results 1 to 3 of 3

Macro clearing data from a range not asked to do so

Threaded View

  1. 09-12-2017, 03:00 AM #1
    Ramzes
    Ramzes is offline
    Forum Contributor
    Join Date
    12-02-2009
    Location
    Birmingham, UK
    MS-Off Ver
    2007
    Posts
    185

    Macro clearing data from a range not asked to do so

    Hello All,

    I have compiled a Macro that runs over my file and does quite a few bits together but in the end it clears contents from the columns A:D. It seems that it happens as of row 5 [header row] and goes to the end of the first set of data [determined by column E = number of OPs].

    I have added the data back to the missing range and run the macro again [the next day] and this time it seems it removed two sets of data!

    Sub AddWO2List()
'
' AddWO2List Macro
'
    Call FilterOut
    Call InitialClear
    Call DeleteRows
    Call TransfWO
    Call Formulas
    Call Sorting
    Call ClearWOInfo
    Call DisplayInfo
'
End Sub

Sub FilterOut()
'
' FilterOut Macro
'
    Sheets("Overview").Activate
    On Error Resume Next
        ActiveSheet.ShowAllData
    On Error GoTo 0
'
End Sub

Sub InitialClear()
'
' InitialClear Macro
'
    Sheets("Overview").Activate
    On Error Resume Next
        ActiveSheet.ShowAllData
    On Error GoTo 0
Dim lrow3 As Long
Application.ScreenUpdating = False
With Sheets("Overview")
    lrow3 = .Cells(Rows.Count, "C").End(xlUp).Row
    Range("C7:Q" & lrow3).Select
    Selection.FormatConditions.Delete
    Range("W7").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-18]=RC[-17],IF(RC[-6]<>"""",""Delivered"",""""),IF(RC[-6]<>"""",""Completed"",""""))"
    Selection.Copy
    Range("W7:W" & lrow3).Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveSheet.Calculate
    Range("AD7").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(COUNTIFS(C[-27],RC[-27],C[-7],""Delivered"")=1,""Archive"",""Leave"")"
    Selection.Copy
    Range("AD7:AD" & lrow3).Select
    ActiveSheet.Paste
    ActiveSheet.Calculate
    Application.CutCopyMode = False
    ActiveSheet.Calculate
    Range("W7:AD" & lrow3).Select
        Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
End With
'
End Sub

Sub DeleteRows()
'
' DeleteRows Macro
'
Dim lastrow3 As Long
With Sheets("Overview")
    lastrow3 = .Cells(Rows.Count, "C").End(xlUp).Row
    With .Range("A5:AD" & lastrow3)
    .AutoFilter Field:=30, Criteria1:="=Archive*"
    Application.DisplayAlerts = False
    .Offset(1, 0).SpecialCells(xlCellTypeVisible).Rows.Delete
    Application.DisplayAlerts = True
    End With
    .AutoFilterMode = False
End With
    Rows("5:5").Select
    Selection.AutoFilter
    On Error Resume Next
        ActiveSheet.ShowAllData
    On Error GoTo 0
'
End Sub

Sub TransfWO()
'
' TransfWO Macro
'
Dim i As Long, lrow As Long, lrow2 As Long, nrow As Long, rCnt As Long
Dim Mat As String, Order As String, Dt As String, Qty As String
Application.ScreenUpdating = False
With Sheets("New WIP WO")
    lrow = .Cells(Rows.Count, "A").End(xlUp).Row
    For i = 2 To lrow
        Mat = .Range("B" & i): Order = .Range("A" & i): Dt = .Range("C" & i): Qty = .Range("D" & i)
        With Sheets("Database")
            .AutoFilterMode = False
            lrow2 = .Cells(Rows.Count, "A").End(xlUp).Row
            With .Range("A1:I" & lrow2 - 1)
                .AutoFilter Field:=1, Criteria1:=Mat
                rCnt = .Offset(1, 0).SpecialCells(xlCellTypeVisible).Rows.Count
                .Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy
                With Sheets("Overview")
                    nrow = .Cells(Rows.Count, "B").End(xlUp).Row + 1
                    .Range("B" & nrow).Resize(rCnt) = Qty
                    .Range("C" & nrow).Resize(rCnt) = Order
                    .Range("S" & nrow).Resize(rCnt) = Format(Dt, "dd-mmm-yy")
                    .Range("V" & nrow).Resize(rCnt) = Format(Dt, "dd-mmm-yy")
                    .Range("D" & nrow).PasteSpecial xlPasteValues
                    .Range("C" & nrow).Resize(rCnt).NumberFormat = "General"
                End With
            End With
        End With
    Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
'
End Sub

Sub Formulas()
'
' Formulas Macro
'
Dim lrow4 As Long
With Sheets("Overview")
    lrow4 = .Cells(Rows.Count, "C").End(xlUp).Row
    Range("A7").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(LEN(RC[4])=1,CONCATENATE(RC[2],""0"",RC[4]),CONCATENATE(RC[2],RC[4]))"
    Selection.Copy
    Range("A8:A" & lrow4).Select
    ActiveSheet.Paste
    ActiveSheet.Calculate
    Range("A7:A" & lrow4).Select
    Selection.Copy
    Range("A7").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("M7").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(OR(RC[-4]=""Sub-Con"",RC[-4]=""FV"",RC[-4]=""FD"",RC[-4]=""HT"",RC[-4]=""Processing"",RC[-4]=""S/A""),RC[-1],SUM(ROUNDUP(SUM(RC[1]/14),0)+IF(RC[-4]=R[1]C[-4],0,2)))"
    Selection.Copy
    Range("M8:M" & lrow4).Select
    ActiveSheet.Paste
    ActiveSheet.Calculate
    Range("M7:M" & lrow4).Select
    Selection.Copy
    Range("M7").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("N7").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(OR(RC[-5]=""Sub-Con"",RC[-5]=""FV"",RC[-5]=""FD"",RC[-5]=""HT"",RC[-5]=""Processing"",RC[-5]=""S/A""),0,SUM(SUM(RC[1]*RC[-3])+RC[-2]))"
    Selection.Copy
    Range("N7:N" & lrow4).Select
    ActiveSheet.Paste
    ActiveSheet.Calculate
    Range("N7:N" & lrow4).Select
    Selection.Copy
    Range("N7").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("O7").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-12]=0,0,IF(RC[-10]=1,RC[-13],SUM(R[-1]C-R[-1]C[5])))"
    Selection.Copy
    Range("O8:O" & lrow4).Select
    ActiveSheet.Paste
    ActiveSheet.Calculate
    Range("P7").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-11]=RC[-10],SUM(RC[3]-RC[-3]),SUM(R[1]C-RC[-3]))"
    Selection.Copy
    Range("P8:P" & lrow4).Select
    ActiveSheet.Paste
    ActiveSheet.Calculate
    Range("P7:P" & lrow4).Select
    Selection.Copy
    Range("P7").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("R7").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-13]=1,IF(RC[-1]<>"""",SUM(RC[-2]-RC[-5]),IF(SUM(RC[-2]-RC[-5])<R1C4,R1C4,SUM(RC[-2]-RC[-5]))),IF(R[-2]C[-1]="""",SUM(R[-2]C+R[-2]C[-5]),SUM(R[-2]C[-1]+1)))"
    Selection.Copy
    Range("R8:R" & lrow4).Select
    ActiveSheet.Paste
    ActiveSheet.Calculate
    Range("R7:R" & lrow4).Select
    Selection.Copy
    Range("R7").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("W7").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-18]=RC[-17],IF(RC[-6]<>"""",""Delivered"",""""),IF(RC[-6]<>"""",""Completed"",""""))"
    Selection.Copy
    Range("W8:W" & lrow4).Select
    ActiveSheet.Paste
    ActiveSheet.Calculate
    Range("Z7").Select
    ActiveCell.FormulaR1C1 = "=WEEKNUM(RC[-10],1)"
    Selection.Copy
    Range("Z8:Z" & lrow4).Select
    ActiveSheet.Paste
    ActiveSheet.Calculate
    Range("Z7:Z" & lrow4).Select
    Selection.Copy
    Range("Z7").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("AA7").Select
    ActiveCell.FormulaR1C1 = "=YEAR(RC[-11])"
    Selection.Copy
    Range("AA8:AA" & lrow4).Select
    ActiveSheet.Paste
    ActiveSheet.Calculate
    Range("AA7:AA" & lrow4).Select
    Selection.Copy
    Range("AA7").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("AB7").Select
    ActiveCell.FormulaR1C1 = "=WEEKNUM(RC[-10],1)"
    Selection.Copy
    Range("AB8:AB" & lrow4).Select
    ActiveSheet.Paste
    ActiveSheet.Calculate
    Range("AB7:AB" & lrow4).Select
    Selection.Copy
    Range("AB7").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("AC7").Select
    ActiveCell.FormulaR1C1 = "=YEAR(RC[-11])"
    Selection.Copy
    Range("AC8:AC" & lrow4).Select
    ActiveSheet.Paste
    ActiveSheet.Calculate
    Range("AC7:AC" & lrow4).Select
    Selection.Copy
    Range("AC7").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("AD7").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(COUNTIFS(C[-27],RC[-27],C[-7],""Delivered"")=1,""Archive"",IF(LEFT(RC[-27],2)=""PL"",""Planned"",""Leave""))"
    Selection.Copy
    Range("AD8:AD" & lrow4).Select
    ActiveSheet.Paste
    ActiveSheet.Calculate
    Range("AD7:AD" & lrow4).Select
    Selection.Copy
    Range("AD7").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
End With
'
End Sub

Sub Sorting()
'
' Sorting Macro
'
Dim lastrow4 As Long
With Sheets("Overview")
    lastrow4 = .Cells(Rows.Count, "C").End(xlUp).Row
    Range("A7:AD" & lastrow4).Select
    ActiveWorkbook.Worksheets("Overview").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Overview").Sort.SortFields.Add Key:=Range( _
        "D7:D" & lastrow4), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Overview").Sort.SortFields.Add Key:=Range( _
        "S7:S" & lastrow4), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Overview").Sort.SortFields.Add Key:=Range( _
        "C7:C" & lastrow4), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Overview").Sort.SortFields.Add Key:=Range( _
        "E7:E" & lastrow4), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Overview").Sort
        .SetRange Range("A7:AD" & lastrow4)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("C6:Q6").Select
    Selection.Copy
    Range("C7:Q" & lastrow4).Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Range("A1").Select
End With
'
End Sub

Sub ClearWOInfo()
'
' ClearWOInfo Macro
'
Dim lrow5 As Long
With Sheets("New WIP WO")
    lrow5 = .Cells(Rows.Count, "A").End(xlUp).Row
    Range("A2:D" & lrow5).Select
    Selection.ClearContents
    Range("G1").Select
    ActiveCell.FormulaR1C1 = "=TODAY()"
    Range("G1").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("A2").Select
End With
'
End Sub
Sub DisplayInfo()
'
' DisplayInfo Macro
'
    Sheets("Instructions").Select
    Range("L2:Q8").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    Selection.Font.Bold = True
    With Selection.Font
        .Name = "Courier New"
        .Size = 26
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    With Selection.Font
        .Name = "Courier New"
        .Size = 20
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("L2:Q8").Select
    ActiveCell.FormulaR1C1 = _
        "New W/O's have now been added to the overview"
    Range("L11:Q16").Select
'
End Sub
    I kept scanning through this and cannot find anything.

    When running I have had to adjust something in the sorting Macro and until then it was fine. I cannot understand why it is doing this. If anyone can see the are in the code that is causing this please highlight it.

    thank you in advance for your help.

    Simon
    Attached Files Attached Files
    ...and this is when I walk in, dressed fully in white...
    Reply With QuoteRegister To Reply
« Previous Thread | Next Thread »

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Similar Threads

  1. [SOLVED] MACRO FOR GO TO SPECIAL for clearing data in all sheets
    By laansesu in forum Excel Programming / VBA / Macros
    Replies: 1
    Last Post: 07-10-2016, 09:55 AM
  2. [SOLVED] Macro to filter data clearing issue
    By kingsp in forum Excel Programming / VBA / Macros
    Replies: 3
    Last Post: 09-28-2014, 09:08 AM
  3. Data Validation: Date asked, ignores when whole number entered
    By mattl75 in forum Excel General
    Replies: 2
    Last Post: 07-24-2012, 09:18 AM
  4. Repeat section of a Macro after YES/NO question is asked.
    By gonzalraf in forum Excel Programming / VBA / Macros
    Replies: 6
    Last Post: 01-28-2012, 07:57 PM
  5. Clearing all data filters by macro
    By Andrew-Mark in forum Excel Programming / VBA / Macros
    Replies: 6
    Last Post: 11-17-2011, 09:58 PM
  6. Macro to clear cell data without clearing headings
    By DOOGIE in forum Excel Programming / VBA / Macros
    Replies: 3
    Last Post: 07-19-2006, 08:50 AM
  7. Macro - asked username & password and sign into Yahoo Finance
    By cbnowhere in forum Excel Programming / VBA / Macros
    Replies: 0
    Last Post: 02-02-2006, 04:50 PM

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Forum Rules


Search Engine Friendly URLs by vBSEO 3.6.0 RC 1