Scribd
Upload
81 views

CPR Macro

This VBA macro unmerges cells, deletes rows, formats cells, and performs other cleanup tasks on multiple worksheets in a workbook. It unmerges cells, deletes header rows, deletes rows with non-numeric or blank data in column E, adds a new column for owner name and fills it with lookup formulas, adjusts column widths, and converts text to numbers in column E. It loops through each worksheet, finds the last used cell, and performs these actions to standardize the data format.

Uploaded by

correzone
Copyright
© Attribution Non-Commercial (BY-NC)
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
81 views

CPR Macro

This VBA macro unmerges cells, deletes rows, formats cells, and performs other cleanup tasks on multiple worksheets in a workbook. It unmerges cells, deletes header rows, deletes rows with non-numeric or blank data in column E, adds a new column for owner name and fills it with lookup formulas, adjusts column widths, and converts text to numbers in column E. It loops through each worksheet, finds the last used cell, and performs these actions to standardize the data format.

Uploaded by

correzone
Copyright
© Attribution Non-Commercial (BY-NC)
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
You are on page 1/ 3

Public Sub Unmergeandfill() Dim r As Excel.Range Dim r1 As Excel.Range Dim myR As Excel.

Range Dim rcount As Integer Dim WS_Count As Integer Dim IntI, IntJ As Integer Dim IntK As Integer WS_Count = ActiveWorkbook.Worksheets.Count For IntI = 1 To WS_Count If ActiveWorkbook.Worksheets(IntI).Name = "T & E" Or ActiveWorkbook.Workshee ts(IntI).Name = "Professional Services" _ Or ActiveWorkbook.Worksheets(IntI).Name = "Relocation Expenses" Or Activ eWorkbook.Worksheets(IntI).Name = "Other Costs and Indirect Costs" Then ActiveWorkbook.Worksheets(IntI).Activate For Each r In ActiveSheet.UsedRange If r.MergeArea.Count > 1 Then Set myR = r.MergeArea r.UnMerge For Each r1 In myR r1.Value2 = myR.Value2 Next r1 End If Next r Set r = Nothing If ActiveSheet.UsedRange.Cells(6, 1) = "Kimberly-Clark Corporation -- [ 1201014]" Then Rows("1:7").Select Selection.Delete Shift:=xlUp End If rcount = 1 For Each r In ActiveSheet.UsedRange If Trim(Cells(rcount, 5)) = "" Then Exit For If IsNumeric(Trim(Cells(rcount, 5))) = False And Trim(Cells(rcount, 5)) <> "Project Code" Then Debug.Print Cells(rcount, 5) Cells(rcount, 5).EntireRow.Select Debug.Print Cells(rcount, 5) Selection.Delete Shift:=xlUp End If rcount = rcount + 1 Next r rcount = 1 For Each r In ActiveSheet.UsedRange If Trim(Cells(rcount, 5)) = "" Then Exit For If IsNumeric(Trim(Cells(rcount, 5))) = False And Trim(Cells(rcount, 5)) <> "Project Code" Then Debug.Print Cells(rcount, 5) Cells(rcount, 5).EntireRow.Select Debug.Print Cells(rcount, 5) Selection.Delete Shift:=xlUp End If rcount = rcount + 1 Next r rcount = 1 For Each r In ActiveSheet.UsedRange

If Trim(Cells(rcount, 5)) = "" Then Exit For If IsNumeric(Trim(Cells(rcount, 5))) = False And Trim(Cells(rcount, 5)) <> "Project Code" Then Debug.Print Cells(rcount, 5) Cells(rcount, 5).EntireRow.Select Debug.Print Cells(rcount, 5) Selection.Delete Shift:=xlUp End If rcount = rcount + 1 Next r Dim LastCol As Integer With ActiveSheet LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column If ActiveSheet.Cells(1, LastCol) <> "Owner Name" Then Range("M1").Select Selection.Copy ActiveSheet.Cells(1, LastCol + 1) = "Owner Name" ActiveSheet.Cells(1, LastCol + 1).Select Set r = Selection Range(r.Address).Select Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False ActiveSheet.Cells(2, LastCol + 1).Select ' ActiveCell.Formula = "=VLOOKUP(E2,Masters!$A$2:$E$64,5,FALSE)" ActiveSheet.Cells(2, LastCol + 1).Select Set r = Selection Range(r.Address).Select '' Dim lRow As Long, lCol As Integer, mRow As Long, mCol As Integer lCol = ActiveSheet.UsedRange.Columns.Count + 1 mRow = 0 For i = 1 To lCol lRow = Range(Cells(Rows.Count, i), Cells(Rows.Count, i)).End (xlUp).Row If lRow > mRow Then mRow = lRow mCol = i Else End If Next i Lastcell = Range(Cells(mRow, lCol), Cells(mRow, lCol)).Address Range(r.Address, Lastcell).Formula = "=VLOOKUP(E2,Masters!$A$2:$ E$64,5,FALSE)" Range(r.Address, Lastcell).Font.Name = "Arial" Range(r.Address, Lastcell).Font.Size = 8 Range(r.Address, Lastcell).Font.Bold = True Range(r.Address, Lastcell).Borders.LineStyle = xlContinuous Range(r.Address, Lastcell).ColumnWidth = 12 Dim NumberOfRows As Integer NumberOfRows = Range("E65536").End(xlUp).Row ' ' ' For IntK = NumberOfRows To NumberOfRows + 4 Cells(NumberOfRows + 1, 5).EntireRow.Select Selection.Delete Shift:=xlDown

'

Next IntK

For IntJ = 2 To NumberOfRows If Range("E" & IntJ).Errors.Item(xlNumberAsText).Value Then Range("E" & IntJ) = Range("E" & IntJ) * 1 End If Next IntJ End If End With End If Next IntI End Sub

You might also like