Excel VBA Macro Delete all images / drawing objects from sheet in one go

Excel VBA Macro code to Delete all images / drawing objects from sheet in one go:

Sub DelObjects()
Dim sh As Worksheet
For Each sh In ActiveWorkbook.Sheets
          On Error Resume Next
          sh.DrawingObjects.Delete
          sh.OLEObjects.Delete
Next sh
MsgBox "Done!"
End Sub

Cheers!!

Excel formula to find overlapping dates in columns

Query: I have a range of dates, start date and end date in a single row in below format.

I want to check for overlap for in each row using formula .

Solution:

An overlap exists if any of end date is equal to or lesser than start date for other blocks or any of  start date is equal to or greater than end date for other blocks.

We will compare each end date for criteria 1 & compare each start date criteria 2 as mentioned above using following formula.

=IF(SUMPRODUCT((INDEX((A2:F2)*(MOD(COLUMN(A2:F2),2)<>0),,)<=TRANSPOSE(INDEX((B2:G2)*(MOD(COLUMN(B2:G2),2)=0),,)))*(INDEX((B2:G2)*(MOD(COLUMN(B2:G2),2)=0),,)>=TRANSPOSE(INDEX((A2:F2)*(MOD(COLUMN(A2:F2),2)<>0),,))))>1,"Overlap","No Overlap")

Download sample file.

Post your feedback below & write your query to www.ExcelVbaLab.Com

Cheers!! 

Excel formula : Find Bottom 5 values excluding zero

Query:

I have list of numbers from that i want to extract smallest 5 numbers excluding zero.

Solution:

we can use combination of Small & count if to get the same. Copy below formula and paste down to cell B1 to B5

=SMALL($A$1:$A$100,COUNTIF($A$1:$A$100,0)+ROW(A1))



Here first count if formula will count for count of numbers equal to zero & will add 1 to it for finding lowest number greater than zero and so on.

Cheers!!

Excel VBA macro highlight break in attendance / gap in dates

Query: I have downloaded attendance data/log from application employee wise, I want to highlight break days. e.g. if an employee has worked from 1 to 15th , and his next attendance is on 22nd I want to highlight 22nd and similar such data. Also there 5 working days for some employees & 6 working days for others. All Sundays are compulsory holidays & Saturday is extra holidays for those who are working for 5 days.

Data format is as below:

Solution:

Again we will use VBA to get work done, sequence will be :

Read EmpID & Date into array,
Sort array EmpID wise & then date wise using bubble sort method.
Now loop through value in array & check for break.

Code goes here:

Sub spot_break_rev()

Dim Arr() As Variant
Dim Temp As Variant
Dim Txt As String
Dim i As Long
Dim j As Long
Dim lr As Long
Dim k As Long

lr = Range("A" & Rows.Count).End(xlUp).Row
    
With Cells.Interior
     .Pattern = xlNone
     .TintAndShade = 0
     .PatternTintAndShade = 0
End With
    
'Allocate value to dynamic array
ReDim Arr(0 To lr - 2)
    
'Fill the array with the keys from the Dictionary
For i = 0 To lr - 2
    Arr(i) = Cells(i + 2, "A") & "^" & Cells(i + 2, "C") & "~" & i + 2
Next i
    
'Sort the array using the bubble sort method
'Sory by emp code
For i = LBound(Arr) To UBound(Arr) - 1
    For j = i + 1 To UBound(Arr)
        If Arr(i) > Arr(j) Then
           Temp = Arr(j)
           Arr(j) = Arr(i)
           Arr(i) = Temp
           End If
    Next j
Next i

'Sort the array using the bubble sort method
'Sory by date if any left out
For i = LBound(Arr) To UBound(Arr) - 1
    For j = i + 1 To UBound(Arr)
    If Split(Arr(i), "^")(0) = Split(Arr(j), "^")(0) Then
           If Split(Arr(i), "^")(0) > Split(Arr(j), "^")(0) Then
           Temp = Arr(j)
           Arr(j) = Arr(i)
           Arr(i) = Temp
           End If
    End If
    Next j
Next i

For i = LBound(Arr) To UBound(Arr) - 1
    k = 0
    If Split(Arr(i), "^")(0) = Split(Arr(i + 1), "^")(0) Then
       If (CDate(Split(Split(Arr(i), "^")(1), "~")(0)) + 1) * 1 <> _
          (CDate(Split(Split(Arr(i + 1), "^")(1), "~")(0))) * 1 Then
          If Day(CDate(Split(Split(Arr(i + 1), "^")(1), "~")(0))) <> 7 Then
             If Cells(Split(Arr(i + 1), "~")(1), "D") <> 6 Then 'chage column no. of days
             Cells(Split(Arr(i + 1), "~")(1), "A").EntireRow.Interior.Color = vbYellow
             End If
          End If
       End If
       k = k + 1
    End If
    If k = 0 Then
    Cells(Split(Arr(i), "~")(1), "A").EntireRow.Interior.Color = vbYellow
    End If
    If k = 0 And i = UBound(Arr) - 1 Then
    Cells(Split(Arr(i), "~")(1) + 1, "A").EntireRow.Interior.Color = vbYellow
    End If
    
Next i

End Sub

You can download file from here:

Provide us your valuable feedback & post your query on www.ExcelVbaLab.Com

Cheers!!

Excel Unique & Difficult formula : Find date when target is achieved (Running total / Cumulative sum for item exceeding target)

Query:

I want a formula for searching date when a total target for particular agent exceeds between select dates. Basically, I have data sheet in which there is a date wise running sales of each agent, there is not a column of running total for each agent in it. I want to know for between any given dates, in a summary sheet for an agent on which date sales has exceeded a given target.

My database is maintained as below

I want a result in the last column from above date

Solution:

Since you are trying to extract result for not standard date range adding running total column will be of no use. Let's construct formula get the desired result:

Step -1 So first we will require to fetch a range which matches an agent name and which is within a date specified, 

=INDEX((Data!$B$2:$B$1000=B8)*(Data!$A$2:$A$1000>=C8)*(Data!$A$2:$A$1000<=D8)*ROW(Data!$C$2:$C$1000),,)

Above formula will give row number of meeting criterion we can get cell address by using formula

=(Data!$C$2:$C$1000)*( if (Step1_Formula>0,1,0) ),

so revised formula will be :

=(Data!$C$2:$C$1000)*(IF(INDEX((Data!$B$2:$B$1000=B8)*(Data!$A$2:$A$1000>=C8)*(Data!$A$2:$A$1000<=D8)*ROW(Data!$C$2:$C$1000),,)>0,1,0))

Here we are checking that if in step 1 formula if a value is zero (i.e. nonmatching item then keep row number to zero else keep this as 1, and multiply this array to data range to get the address of the matching value.

Step -2 Now since we have extracted the daily sales value of required criterion, then we will convert this daily sales value to cumulative sales value. E.G. we have extracted sales values as {100,100,0,0,100} but what we need to match is cumulative sales i.e. {100,200,200,200,300}.

To convert 1st array {100,100,0,0,100} to {100,200,200,200,300} we will use Matrix Multiplication formula, i.e. MMULT.

E.G. You have data in cell A1 to A5 as 1,2,3,4,5 and when you use MMULT formula as follows:

=MMULT(--(ROW(A1:A5)>=TRANSPOSE(ROW(A1:A5))),A1:A5)

Formula will return cumulative sum as {1,3,6,10,15}, i.e. cumulative sum is returned in array. Note MMULT is an array formula so after entering formula instead of pressing enter, use the combination of CSE keys (Control + Shift + Enter keys).

so our formula will look like as below:

=MMULT(--(ROW(Data!$E$2:$E$1000)>=TRANSPOSE(ROW(Data!$E$2:$E$1000))),(Data!$C$2:$C$1000)*(IF(INDEX((Data!$B$2:$B$1000=B8)*(Data!$A$2:$A$1000>=C8)*(Data!$A$2:$A$1000<=D8)*ROW(Data!$C$2:$C$1000),,)>0,1,0)))

Step -3 As we have received cumulative sum/total we can use LOOKUP formula & get resultant day by assigning array to it by using formula:

=LOOKUP(E8, Step2_Formula, Data!$A$2:$A$1000)+1

So final formula will look like this: 

{=LOOKUP(E8,MMULT(--(ROW(Data!$E$2:$E$1000)>=TRANSPOSE(ROW(Data!$E$2:$E$1000))),(Data!$C$2:$C$1000)*(IF(INDEX((Data!$B$2:$B$1000=B8)*(Data!$A$2:$A$1000>=C8)*(Data!$A$2:$A$1000<=D8)*ROW(Data!$C$2:$C$1000),,)>0,1,0))),Data!$A$2:$A$1000)+1}

Enter above formula as an array to get the desired result.

Download example sheet by clicking here.

Comment about this article & post your query below, also you can ask your query on www.ExcelVbaLab.Com

Cheers!!

Excel Pivot table - Conditional formatting pivot table & maintaining format after filtering and un filtering data

Query: I have a pivot table and I want to have the format apply to any cell in the data area, regardless of the configuration of the column and row fields. I want the formatting to fit whatever the table displays and also same to get refreshed whenever data is refreshed. I tried applying it but as soon as data is filtered out conditional formatting gets lost.

Solution: You can follow steps as below:

Step 1 - Select whole  data area,
Step 2 - click on Conditional Formatting on the Home tab of the Ribbon and choose the conditional format you want to apply.
Step 3 - Click on rectangle box at the right end corner,

Step 4 - Select the last option from radio button,

You can also refer below image



Post your query and feedback on ExcelVbaLab.com

Cheers!!

Excel VBA Macro to compare employee data head wise between multiple sheet and give out to separate sheet

Query: Hi I have employee master data in two or sometimes three or more sheets, I want to match data in all sheets and get the comparison in new sheets, where macro to check head wise employee wise amount and highlight if miss match.

Ans:

Since there are multiple sheets to compare, we need to loop through all sheets & take unique employee number from all sheets, and similarly extract unique headers from all sheets.

Once we have extracted the same we can generate the ouput in new sheet where we can pull employee details and corresponding head wise amount from different sheet, then we can match amount in next column and highlight the same.

Code goes here:

Option Explicit
Sub Generate_Diff_V2()
Dim key As Variant
Dim cell As Range, cell2 As Range
Dim wb As Workbook
Dim i As Integer, j As Integer
Dim dict As Object, dict2 As Object
Dim cell3 As Range
Set wb = ThisWorkbook
Dim app

Set app = Application.WorksheetFunction
Set dict = CreateObject("Scripting.Dictionary")
Set dict2 = CreateObject("Scripting.Dictionary")
    
Application.ScreenUpdating = False
dict.RemoveAll
dict2.RemoveAll

For i = 1 To wb.Worksheets.Count
If Sheets(i).Name <> "Output" Then

Sheets(i).Select
For Each cell In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
If Not dict.exists(Val(cell)) Then
dict.Add Val(cell), cell.Offset(0, 1)
End If
Next

For Each cell In Range(Range("C1"), Cells(1, Range("A1").End(xlToRight).Column))
If Not dict2.exists(cell.Value) Then
dict2.Add cell.Value, cell.Value
End If
Next

End If

Next i
     
Sheets("Output").Select
Cells.Clear
Cells(3, 1).Resize(dict.Count) = Application.Transpose(dict.Keys)

For Each cell3 In Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row)
cell3.Offset(0, 1).Value = dict(Val(cell3))
Next cell3

Dim k As Integer
Dim rr As Long, cc As Long

k = 2
Cells(2, 1).Value = "ID"
Cells(2, 2).Value = "Name"

For Each key In dict2.Keys
For i = 1 To Worksheets.Count
If Sheets(i).Name <> "Output" Then


Cells(1, k + 1).Value = key
Cells(2, k + 1).Value = Sheets(i).Name

On Error Resume Next
cc = 0
cc = Sheets(i).Range("A1:ZZ1").Find(key, LookIn:=xlValues).Column

For Each cell In Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row)
On Error Resume Next
rr = 0
rr = Sheets(i).Range("A1:A100000").Find(cell.Value, LookIn:=xlValues).Row
If rr <> 0 And cc <> 0 Then
cell.Offset(0, k).Value = Sheets(i).Cells(rr, cc).Value
Else
cell.Offset(0, k).Value = 0
End If
Next cell

k = Range("ZZ3").End(xlToLeft).Column  'k + 6

End If
Next i

Cells(2, k + 1).Value = "Diff"
For Each cell In Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row)
'For j = 1 To Worksheets.Count - 1 'dict2.Count
'cell.Offset(0, k).Value = cell.Offset(0, k).Value - cell.Offset(0, k - j).Value
'Next j
j = Worksheets.Count - 1
cell.Offset(0, k).Value = app.Max(Range(cell.Offset(0, k - j), cell.Offset(0, k - 1))) _
= app.Min(Range(cell.Offset(0, k - j), cell.Offset(0, k - 1)))
If Not cell.Offset(0, k).Value Then
cell.Offset(0, k).Interior.Color = vbRed
End If
Next cell
k = Range("ZZ3").End(xlToLeft).Column + 1 'k + 6

Next key

Cells.EntireColumn.AutoFit
Application.ScreenUpdating = True

End Sub

You can also download sample file from here:

Post your query & comments below, you can also post your query at www.ExcelVbaLab.com

Cheers!!