Posts by Max1616

Max1616 · Jun 10th 2016

Re: Truncate variable in chart title

Try this:

Code

With ActiveChart 
    .HasTitle = True 
    .ChartTitle.Select 
    .ChartTitle.Text = "Last " & Format(Age/ 30, "#,###.0") & " months" 
End With

Max1616 · Jun 9th 2016

Re: Looping through blocks of data

Yep you worked it out yourself!

Glad my code works!

Sorry about not diming that as long, I should have done that initially but I forgot to. Let me know if you need anything else!

Max1616 · Jun 9th 2016

Re: Looping through blocks of data

Try this:

Code

Sub AnthonyDSA()
Dim OPID As Variant
Dim lrow As Long
Dim i As Integer
Dim OP As String




lrow = Cells(Rows.Count, 1).End(xlUp).Row
OP = "Operator"
OPID = 0


For i = 2 To lrow
    'If column A contains the word "Operator" Then...
    If InStr(Cells(i, 1), OP) <> 0 Then
        'Your Operator ID is the contents of the cell, but remove "Operator:" and "Totals" if either of those values exist.
        OPID = WorksheetFunction.Substitute(WorksheetFunction.Substitute(Cells(i, 1), OP & ":", ""), "Totals", "")
        GoTo Nexti
        'The above will update what your Operator ID is for each row while running the loop
    End If
    
    'I'm not sure what you wanted so I just made the macro label each row with it's corresponding Operator ID. You can replace this code with your code.
    If Cells(i, 1) <> "" Then
        'Code goes here
        Cells(i, 5) = OP & ":"
        Cells(i, 6) = OPID
    End If


Nexti:
Next i




End Sub

Display More

Max1616 · Jun 2nd 2016

Re: Macro to Filter/Save As Not Working

Sorry for the delay. Try this:

Code

Sub ExportMFTasks()
    BeginRow = 35
    EndRow = 400
    ChkCol = 3
    Dim MyWB As Workbook
    Dim NewWB As Workbook
     
    Set MyWB = ActiveWorkbook
    Application.ScreenUpdating = False
     
    Cells.Select
    On Error Resume Next
    Selection.EntireRow.Hidden = False
    Range("A1").Select
    For RowCnt = BeginRow To EndRow
        If Cells(RowCnt, ChkCol).Value = "COE" Then
            Cells(RowCnt, ChkCol).EntireRow.Hidden = True
        End If
        If Cells(RowCnt, ChkCol).Value = "COE Strategy" Then
            Cells(RowCnt, ChkCol).EntireRow.Hidden = True
        End If
        If Cells(RowCnt, ChkCol).Value = "COE Delivery" Then
            Cells(RowCnt, ChkCol).EntireRow.Hidden = True
        End If
        If Cells(RowCnt, ChkCol).Value = "COE Delivery/COE Strategy" Then
            Cells(RowCnt, ChkCol).EntireRow.Hidden = True
        End If
        If Cells(RowCnt, ChkCol).Value = "Vendor/COE Strategy" Then
            Cells(RowCnt, ChkCol).EntireRow.Hidden = True
        End If
        If Cells(RowCnt, ChkCol).Value = "Vendor/COE Delivery" Then
            Cells(RowCnt, ChkCol).EntireRow.Hidden = True
        End If
        If Cells(RowCnt, ChkCol).Value = "PCM" Then
            Cells(RowCnt, ChkCol).EntireRow.Hidden = True
        End If
        If Cells(RowCnt, ChkCol).Value = "RIO" Then
            Cells(RowCnt, ChkCol).EntireRow.Hidden = True
        End If
        If Cells(RowCnt, ChkCol).Value = "Quality Manager" Then
            Cells(RowCnt, ChkCol).EntireRow.Hidden = True
        End If
        If Cells(RowCnt, ChkCol).Value = "Vendor/COE" Then
            Cells(RowCnt, ChkCol).EntireRow.Hidden = True
        End If
    Next RowCnt
     
    Application.ScreenUpdating = True
     
     'Adds new workbook
    Set NewWB = Workbooks.Add
     
    MyWB.Activate
    
    MyWB.Sheets("CAMPAIGN").Range(Rows(1), Rows(BeginRow - 1)).Copy Destination:=NewWB.Sheets(1).Cells(1, 1)
    
    MyWB.Sheets("CAMPAIGN").Range(Rows(BeginRow), Rows(EndRow)).Select
    Selection.SpecialCells(xlCellTypeVisible).Copy Destination:=NewWB.Sheets(1).Cells(BeginRow, 1)
     
    NewWB.Activate
    ActiveWindow.DisplayGridlines = False
    Cells.WrapText = False
    Columns(1).EntireColumn.AutoFit
    Range(Columns(3), Columns(11)).EntireColumn.AutoFit
    
    MyWB.Activate
     
    NewWB.SaveAs Filename:= _
    Environ$("USERPROFILE") & "\Desktop\MF Task Export.xlsx", FileFormat:=xlOpenXMLWorkbook _
    , CreateBackup:=False
     
    NewWB.Close False
     
    MyWB.Activate
    Cells.Select
    On Error Resume Next
    Selection.EntireRow.Hidden = False
    Range("A1").Select
End Sub

Display More

I adjusted some code and your begin row number.

Max1616 · Jun 1st 2016

Re: VBA: adding variable fields to a pivot table

First question:

Code

Dim y as long
Dim pos as date


y = cells(rows.count,5).End(xlup).row
pos= Cells(y,5)

I think I'm confused on your second question. If you are adding pivot fields, that would mean each column of data should be it's own field. Are your years seperated out by columns? What does your data set look like and what does the end pivot table look like?

Thanks!

Max1616 · Jun 1st 2016

Re: Macro to Filter/Save As Not Working

is it possible for you to attach your sheet? Where is the merged cell in your data set?

Max1616 · Jun 1st 2016

Re: Run-time error '1004 Command could not be completed by using the range specified

This should be working fine, I see no errors with the code, which makes me think there's an error with your dataset. Can you attach an example workbook? How many rows are in column A?

This error should only come up when there is nothing to filter.

Max1616 · Jun 1st 2016

Re: Macro to Filter/Save As Not Working

Caught one more error that is not excluding the hidden cell when copying (sorry I was doing it by freehand before) I just tested this one and it works:

Code

Sub ExportMFTasks()
    BeginRow = 20
    EndRow = 400
    ChkCol = 3
    Dim MyWB As Workbook
    Dim NewWB As Workbook
    
    Set MyWB = ActiveWorkbook
    Application.ScreenUpdating = False
     
    Cells.Select
    Selection.EntireRow.Hidden = False
    Range("A1").Select
    For RowCnt = BeginRow To EndRow
        If Cells(RowCnt, ChkCol).Value = "COE" Then
            Cells(RowCnt, ChkCol).EntireRow.Hidden = True
        End If
        If Cells(RowCnt, ChkCol).Value = "COE Strategy" Then
            Cells(RowCnt, ChkCol).EntireRow.Hidden = True
        End If
        If Cells(RowCnt, ChkCol).Value = "COE Delivery" Then
            Cells(RowCnt, ChkCol).EntireRow.Hidden = True
        End If
        If Cells(RowCnt, ChkCol).Value = "COE Delivery/COE Strategy" Then
            Cells(RowCnt, ChkCol).EntireRow.Hidden = True
        End If
        If Cells(RowCnt, ChkCol).Value = "Vendor/COE Strategy" Then
            Cells(RowCnt, ChkCol).EntireRow.Hidden = True
        End If
        If Cells(RowCnt, ChkCol).Value = "Vendor/COE Delivery" Then
            Cells(RowCnt, ChkCol).EntireRow.Hidden = True
        End If
        If Cells(RowCnt, ChkCol).Value = "PCM" Then
            Cells(RowCnt, ChkCol).EntireRow.Hidden = True
        End If
        If Cells(RowCnt, ChkCol).Value = "RIO" Then
            Cells(RowCnt, ChkCol).EntireRow.Hidden = True
        End If
        If Cells(RowCnt, ChkCol).Value = "Quality Manager" Then
            Cells(RowCnt, ChkCol).EntireRow.Hidden = True
        End If
        If Cells(RowCnt, ChkCol).Value = "Vendor/COE" Then
            Cells(RowCnt, ChkCol).EntireRow.Hidden = True
        End If
    Next RowCnt
     
    Application.ScreenUpdating = True
    
    'Adds new workbook
    Set NewWB = Workbooks.Add
    
    MyWB.Activate
    MyWB.Sheets("CAMPAIGN").Cells.Select
    Selection.SpecialCells(xlCellTypeVisible).Copy Destination:=NewWB.Sheets(1).Cells(1, 1)


    NewWB.SaveAs Filename:= _
    Environ$("USERPROFILE") & "\Desktop\MF Task Export.xlsx", FileFormat:=xlOpenXMLWorkbook _
    , CreateBackup:=False
    
    NewWB.Close False
    
    MyWB.Activate
    Cells.Select
    Selection.EntireRow.Hidden = False
    Range("A1").Select
End Sub

Display More

Max1616 · Jun 1st 2016

Re: Macro to Filter/Save As Not Working

Also you might want to consider changing your end row to be more dynamic to your dataset. I usually use something like this:

Code

endrow=cells(rows.count,1).end(xlup).row

Just a piece of friendly coding advice

I fixed an error in the code, can you try it again?

Max1616 · Jun 1st 2016

Re: Macro to Filter/Save As Not Working

Code

Sub ExportMFTasks()
    BeginRow = 20
    EndRow = 400
    ChkCol = 3
    Dim MyWB As Workbook
    Dim NewWB As Workbook
    
    Set MyWB = ActiveWorkbook
    Application.ScreenUpdating = False
     
    Cells.Select
    Selection.EntireRow.Hidden = False
    Range("A1").Select
    For RowCnt = BeginRow To EndRow
        If Cells(RowCnt, ChkCol).Value = "COE" Then
            Cells(RowCnt, ChkCol).EntireRow.Hidden = True
        End If
        If Cells(RowCnt, ChkCol).Value = "COE Strategy" Then
            Cells(RowCnt, ChkCol).EntireRow.Hidden = True
        End If
        If Cells(RowCnt, ChkCol).Value = "COE Delivery" Then
            Cells(RowCnt, ChkCol).EntireRow.Hidden = True
        End If
        If Cells(RowCnt, ChkCol).Value = "COE Delivery/COE Strategy" Then
            Cells(RowCnt, ChkCol).EntireRow.Hidden = True
        End If
        If Cells(RowCnt, ChkCol).Value = "Vendor/COE Strategy" Then
            Cells(RowCnt, ChkCol).EntireRow.Hidden = True
        End If
        If Cells(RowCnt, ChkCol).Value = "Vendor/COE Delivery" Then
            Cells(RowCnt, ChkCol).EntireRow.Hidden = True
        End If
        If Cells(RowCnt, ChkCol).Value = "PCM" Then
            Cells(RowCnt, ChkCol).EntireRow.Hidden = True
        End If
        If Cells(RowCnt, ChkCol).Value = "RIO" Then
            Cells(RowCnt, ChkCol).EntireRow.Hidden = True
        End If
        If Cells(RowCnt, ChkCol).Value = "Quality Manager" Then
            Cells(RowCnt, ChkCol).EntireRow.Hidden = True
        End If
        If Cells(RowCnt, ChkCol).Value = "Vendor/COE" Then
            Cells(RowCnt, ChkCol).EntireRow.Hidden = True
        End If
    Next RowCnt
     
    Application.ScreenUpdating = True
    
    'Adds new workbook
    Set NewWB = Workbooks.Add
    
    MyWB.Activate
    MyWB.Sheets("CAMPAIGN").Select
    MyWB.Sheets("CAMPAIGN").Cells.Copy Destination:=NewWB.Sheets(1).Cells(1, 1)


    NewWB.SaveAs Filename:= _
    Environ$("USERPROFILE") & "\Desktop\MF Task Export.xlsx", FileFormat:=xlOpenXMLWorkbook _
    , CreateBackup:=False
    
    NewWB.Close False
    
    MyWB.Activate
    Cells.Select
    Selection.EntireRow.Hidden = False
    Range("A1").Select
End Sub

Display More

I think your issue is that your code does nothing with the values that are copied. So you do all of the hiding without actually putting the new values in a new workbook.

*Edit fixed an error

Max1616 · Jun 1st 2016

Re: Macro to Filter/Save As Not Working

What line is giving you the error? If no error what is currently happening that makes it not work?

Max1616 · May 17th 2016

Re: Simply-fly Subtotal and add some condition

Run this, assuming your column headers are in row 1 and not row 2:

Code

Sub sachin483()
Dim lrow As Long
Dim i As Long
Dim Sub1 As String
Dim Sub2 As String
Dim Sub3 As String
Dim ORow1 As Long
Dim ORow2 As Long
Dim ORow3 As Long




lrow = Cells(Rows.Count, 1).End(xlUp).Row


Range("H2:H" & lrow).Sort Key1:=Range("H2"), Order1:=xlAscending, Header:=xlYes
Range("F2:F" & lrow).Sort Key1:=Range("F2"), Order1:=xlAscending, Header:=xlYes
Range("D2:D" & lrow).Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlYes
Range("B2:B" & lrow).Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlYes
ORow1 = 0


'Subtotal 1
For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
    Sub1 = Cells(i + 1, 7)
    If i = lrow Then Sub1 = Cells(i, 7)
    If Cells(i + 1, 7) = "" Then Sub1 = Cells(i, 7)
    
    If Cells(i - 1, 7) = Sub1 Then
        GoTo Nexti1
    Else


        If ORow1 = 0 Then ORow1 = lrow + 2
    


        Cells(i, 1).EntireRow.Insert
        
        
        Cells(ORow1, 1) = Cells(i - 1, 1)
        Cells(ORow1, 7) = Sub1 & " Total"
        Cells(ORow1, 9) = "AR_" & Sub1 & " Total"
    
        Cells(ORow1, 10) = WorksheetFunction.Sum(Range(Cells(ORow1 - 1, 10), Cells(i + 1, 10)))
        Cells(ORow1, 11) = WorksheetFunction.Sum(Range(Cells(ORow1 - 1, 11), Cells(i + 1, 11)))
        Cells(ORow1, 12) = WorksheetFunction.Sum(Range(Cells(ORow1 - 1, 12), Cells(i + 1, 12)))
        Cells(ORow1, 13) = WorksheetFunction.Sum(Range(Cells(ORow1 - 1, 13), Cells(i + 1, 13)))
        Cells(ORow1, 14) = WorksheetFunction.Sum(Range(Cells(ORow1 - 1, 14), Cells(i + 1, 14)))
        Cells(ORow1, 15) = WorksheetFunction.Sum(Range(Cells(ORow1 - 1, 15), Cells(i + 1, 15)))
        Cells(ORow1, 16) = WorksheetFunction.Sum(Range(Cells(ORow1 - 1, 16), Cells(i + 1, 16)))
        Cells(ORow1, 17) = WorksheetFunction.Sum(Range(Cells(ORow1 - 1, 17), Cells(i + 1, 17)))
        Cells(ORow1, 18) = WorksheetFunction.Sum(Range(Cells(ORow1 - 1, 18), Cells(i + 1, 18)))
        Cells(ORow1, 19) = WorksheetFunction.Sum(Range(Cells(ORow1 - 1, 19), Cells(i + 1, 19)))
        Cells(ORow1, 20) = WorksheetFunction.Sum(Range(Cells(ORow1 - 1, 20), Cells(i + 1, 20)))
        Cells(ORow1, 21) = WorksheetFunction.Sum(Range(Cells(ORow1 - 1, 21), Cells(i + 1, 21)))
        Cells(ORow1, 22) = WorksheetFunction.Sum(Range(Cells(ORow1 - 1, 22), Cells(i + 1, 22)))
        Cells(ORow1, 23) = WorksheetFunction.Sum(Range(Cells(ORow1 - 1, 23), Cells(i + 1, 23)))
    
        Range(Cells(ORow1, 7), Cells(ORow1, 23)).Interior.ColorIndex = 6
        Cells(ORow1, 7).Font.Bold = True
        
        ORow1 = i + 1
        
        
        If i = 2 Then Rows(2).Delete
        If i = 2 Then Cells(1, 2).End(xlDown).Offset(1, -1) = "XX"
    End If
   
Nexti1:
Next i


'Subtotal 2
lrow = Cells(Rows.Count, 7).End(xlUp).Row


Sub2 = Cells(lrow - 1, 5)
ORow2 = lrow + 1


For i = lrow To 1 Step -1
    If Cells(i, 5) <> "" And Cells(i, 5) <> Sub2 Then
        If i = 1 Then Rows(1).Insert
        If i = 1 Then ORow2 = ORow2 + 1
        
        Cells(ORow2, 1) = "XX"
        Cells(ORow2, 5) = Sub2 & " Total"
        Cells(ORow2, 9) = "RE_" & Sub2 & " Total"
            
        Cells(ORow2, 10) = WorksheetFunction.SumIf(Range(Cells(i + 2, 5), Cells(ORow2 - 2, 5)), Sub2, Range(Cells(i + 2, 10), Cells(ORow2 - 2, 10)))
        Cells(ORow2, 11) = WorksheetFunction.SumIf(Range(Cells(i + 2, 5), Cells(ORow2 - 2, 5)), Sub2, Range(Cells(i + 2, 11), Cells(ORow2 - 2, 11)))
        Cells(ORow2, 12) = WorksheetFunction.SumIf(Range(Cells(i + 2, 5), Cells(ORow2 - 2, 5)), Sub2, Range(Cells(i + 2, 12), Cells(ORow2 - 2, 12)))
        Cells(ORow2, 13) = WorksheetFunction.SumIf(Range(Cells(i + 2, 5), Cells(ORow2 - 2, 5)), Sub2, Range(Cells(i + 2, 13), Cells(ORow2 - 2, 13)))
        Cells(ORow2, 14) = WorksheetFunction.SumIf(Range(Cells(i + 2, 5), Cells(ORow2 - 2, 5)), Sub2, Range(Cells(i + 2, 14), Cells(ORow2 - 2, 14)))
        Cells(ORow2, 15) = WorksheetFunction.SumIf(Range(Cells(i + 2, 5), Cells(ORow2 - 2, 5)), Sub2, Range(Cells(i + 2, 15), Cells(ORow2 - 2, 15)))
        Cells(ORow2, 16) = WorksheetFunction.SumIf(Range(Cells(i + 2, 5), Cells(ORow2 - 2, 5)), Sub2, Range(Cells(i + 2, 16), Cells(ORow2 - 2, 16)))
        Cells(ORow2, 17) = WorksheetFunction.SumIf(Range(Cells(i + 2, 5), Cells(ORow2 - 2, 5)), Sub2, Range(Cells(i + 2, 17), Cells(ORow2 - 2, 17)))
        Cells(ORow2, 18) = WorksheetFunction.SumIf(Range(Cells(i + 2, 5), Cells(ORow2 - 2, 5)), Sub2, Range(Cells(i + 2, 18), Cells(ORow2 - 2, 18)))
        Cells(ORow2, 19) = WorksheetFunction.SumIf(Range(Cells(i + 2, 5), Cells(ORow2 - 2, 5)), Sub2, Range(Cells(i + 2, 19), Cells(ORow2 - 2, 19)))
        Cells(ORow2, 20) = WorksheetFunction.SumIf(Range(Cells(i + 2, 5), Cells(ORow2 - 2, 5)), Sub2, Range(Cells(i + 2, 20), Cells(ORow2 - 2, 20)))
        Cells(ORow2, 21) = WorksheetFunction.SumIf(Range(Cells(i + 2, 5), Cells(ORow2 - 2, 5)), Sub2, Range(Cells(i + 2, 21), Cells(ORow2 - 2, 21)))
        Cells(ORow2, 22) = WorksheetFunction.SumIf(Range(Cells(i + 2, 5), Cells(ORow2 - 2, 5)), Sub2, Range(Cells(i + 2, 22), Cells(ORow2 - 2, 22)))
        Cells(ORow2, 23) = WorksheetFunction.SumIf(Range(Cells(i + 2, 5), Cells(ORow2 - 2, 5)), Sub2, Range(Cells(i + 2, 23), Cells(ORow2 - 2, 23)))
            
        Range(Cells(ORow2, 5), Cells(ORow2, 23)).Interior.ColorIndex = 17
            
            
            
        If i = 1 Then
            Cells(ORow2, 5).Font.Bold = True
            Rows(1).Delete
        Else
            Cells(ORow2, 5).Font.Bold = True
            Cells(i + 2, 1).EntireRow.Insert
        End If
        
        Sub2 = Cells(i, 5)
        ORow2 = i + 2
        
        
        
    End If
Next i






lrow = Cells(Rows.Count, 5).End(xlUp).Row


Sub3 = Cells(lrow - 2, 3)
ORow3 = lrow + 1


For i = lrow To 1 Step -1
    If Cells(i, 3) <> "" And Cells(i, 3) <> Sub3 Then
        
            If i = 1 Then Rows(1).Insert
            If i = 1 Then ORow3 = ORow3 + 1
        
            Cells(ORow3, 1) = "XX"
            Cells(ORow3, 3) = Sub3 & " Total"
            Cells(ORow3, 9) = "ZR_" & Sub3 & " Total"
            
            Cells(ORow3, 10) = WorksheetFunction.SumIf(Range(Cells(i + 2, 3), Cells(ORow3 - 2, 3)), Sub3, Range(Cells(i + 2, 10), Cells(ORow3 - 2, 10)))
            Cells(ORow3, 11) = WorksheetFunction.SumIf(Range(Cells(i + 2, 3), Cells(ORow3 - 2, 3)), Sub3, Range(Cells(i + 2, 11), Cells(ORow3 - 2, 11)))
            Cells(ORow3, 12) = WorksheetFunction.SumIf(Range(Cells(i + 2, 3), Cells(ORow3 - 2, 3)), Sub3, Range(Cells(i + 2, 12), Cells(ORow3 - 2, 12)))
            Cells(ORow3, 13) = WorksheetFunction.SumIf(Range(Cells(i + 2, 3), Cells(ORow3 - 2, 3)), Sub3, Range(Cells(i + 2, 13), Cells(ORow3 - 2, 13)))
            Cells(ORow3, 14) = WorksheetFunction.SumIf(Range(Cells(i + 2, 3), Cells(ORow3 - 2, 3)), Sub3, Range(Cells(i + 2, 14), Cells(ORow3 - 2, 14)))
            Cells(ORow3, 15) = WorksheetFunction.SumIf(Range(Cells(i + 2, 3), Cells(ORow3 - 2, 3)), Sub3, Range(Cells(i + 2, 15), Cells(ORow3 - 2, 15)))
            Cells(ORow3, 16) = WorksheetFunction.SumIf(Range(Cells(i + 2, 3), Cells(ORow3 - 2, 3)), Sub3, Range(Cells(i + 2, 16), Cells(ORow3 - 2, 16)))
            Cells(ORow3, 17) = WorksheetFunction.SumIf(Range(Cells(i + 2, 3), Cells(ORow3 - 2, 3)), Sub3, Range(Cells(i + 2, 17), Cells(ORow3 - 2, 17)))
            Cells(ORow3, 18) = WorksheetFunction.SumIf(Range(Cells(i + 2, 3), Cells(ORow3 - 2, 3)), Sub3, Range(Cells(i + 2, 18), Cells(ORow3 - 2, 18)))
            Cells(ORow3, 19) = WorksheetFunction.SumIf(Range(Cells(i + 2, 3), Cells(ORow3 - 2, 3)), Sub3, Range(Cells(i + 2, 19), Cells(ORow3 - 2, 19)))
            Cells(ORow3, 20) = WorksheetFunction.SumIf(Range(Cells(i + 2, 3), Cells(ORow3 - 2, 3)), Sub3, Range(Cells(i + 2, 20), Cells(ORow3 - 2, 20)))
            Cells(ORow3, 21) = WorksheetFunction.SumIf(Range(Cells(i + 2, 3), Cells(ORow3 - 2, 3)), Sub3, Range(Cells(i + 2, 21), Cells(ORow3 - 2, 21)))
            Cells(ORow3, 22) = WorksheetFunction.SumIf(Range(Cells(i + 2, 3), Cells(ORow3 - 2, 3)), Sub3, Range(Cells(i + 2, 22), Cells(ORow3 - 2, 22)))
            Cells(ORow3, 23) = WorksheetFunction.SumIf(Range(Cells(i + 2, 3), Cells(ORow3 - 2, 3)), Sub3, Range(Cells(i + 2, 23), Cells(ORow3 - 2, 23)))
            
            Range(Cells(ORow3, 3), Cells(ORow3, 23)).Interior.ColorIndex = 40
            Cells(ORow3, 3).Font.Bold = True
            
            
            
        If i = 1 Then
        Rows(1).Delete
        Else
        Cells(i + 3, 1).EntireRow.Insert
        End If
        
        Sub3 = Cells(i, 3)
        ORow3 = i + 3
        
    End If


Next i






End Sub

Display More

I can't really think of a better way to do this outside of writing 3 separate loops. Which means that this could take a while to run depending on how much data you have. But I am able to recreate your 'result' tab that you provided from the data. (Just remember to delete the first row)

Please let me know if this worked!

Sincerely,
Max

Max1616 · May 16th 2016

Re: Simply-fly Subtotal and add some condition

I think it would be easier for others to help you out if you just gave us a list of actions you wanted a macro for. For example:

make a macro that does this
1. Sort Columns A:W in ascending order buy column B
2. Sort Columns A:W in ascending order by column D
3. Sort Columns A:W in ascending order by column F
4. Sort Columns A:W in ascending order by column H
5. In column A indicate a subtotal at the bottom of the sheet
6. In column B indicate a subtotal at the bottom of the sheet
7. In column A indicate a subtotal at the bottom of the sheet
8. Color the Subtotal cells yellow

I don't think this is what you want. But something along these lines will help us formulate a Macro to best suit your needs.

Sincerely,
Max

Max1616 · May 10th 2016

Here is your spreadsheet:
forum.ozgrid.com/index.php?attachment/69067/

http://www.mrexcel.com/forum/e…-based-prior-percent.html

Max1616 · May 6th 2016

Re: Refresh All Does Not Refresh Pivot Table

I was having a similar issue, you can create a macro to update all your pivots for you:

Code

Dim Sheet as WorkSheet, Pivot as PivotTable
For Each Sheet in ThisWorkbook.WorkSheets
    For Each Pivot in Sheet.PivotTables
        Pivot.RefreshTable
        Pivot.Update
    Next
Next

I think the issue stems from having an older version of excel. (but I might be wrong there)

Max1616 · May 3rd 2016

Re: Send Email from Excel (Lotus Notes)

Assuming you are using Outlook:

Code

Sub Email()


'Mail Sub_____________________________________________________________________________________________________________________
    Dim OutApp As Object
    Dim OutMail As Object
        


    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With


    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)


    On Error Resume Next
    With OutMail
        .To = "Test Test <[email protected]>; "
        .CC = "Test 1 <[email protected]>; "
        .BCC = ""
        .Subject = "Memo"
        .HTMLBody = "Body Test"
        .Display   'or use .Display
    End With
    On Error GoTo 0


    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With


    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Display More

Max1616 · Apr 29th 2016

Re: Fetching common (common company) data from different worksheets

Try this:

Code

Sub sannuk7()


Dim NewWs As Worksheet
Dim lrow As Long
Dim i As Long
Dim ws As Integer
Dim StrtD As Integer
Dim EndD As Integer
Dim Cell1 As Range


StrtD = Application.InputBox("Please insert start year", "Start Year", "2000")
EndD = Application.InputBox("Please insert end year", "End Year", Year(Now))


Application.ScreenUpdating = False


On Error Resume Next
Application.DisplayAlerts = False
Sheets("Summary").Delete
Application.DisplayAlerts = True




Set NewWs = Worksheets.Add(After:=Sheets(Sheets.Count))
NewWs.Name = "Summary"


For ws = 1 To Sheets.Count
    If Left(Sheets(ws).Name, 4) >= StrtD And Left(Sheets(ws).Name, 4) <= EndD Then
    Sheets(ws).Columns(1).Copy Destination:=NewWs.Columns(1)
    NewWs.Columns(1).RemoveDuplicates Columns:=1, Header:=xlYes
    NewWs.Range(Cells(2, 1).Address & ":" & Cells(1, 1).End(xlDown).Address).Copy Destination:=NewWs.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
    NewWs.Columns(1).ClearContents
    End If
    
Next ws


NewWs.Columns(2).RemoveDuplicates Columns:=1, Header:=xlNo




Set Cell1 = NewWs.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)


Cell1.Offset(1, -1) = "Symbol"
Cell1.Offset(1, 0) = "Company"
Cell1.Offset(1, 1) = "Director Salutation"
Cell1.Offset(1, 2) = "Director First Name"
Cell1.Offset(1, 3) = "Director Middle Name"
Cell1.Offset(1, 4) = "Director Surname"
Cell1.Offset(1, 5) = "Gender"
Cell1.Offset(1, 6) = "Year"


For ws = 1 To Sheets.Count
    If Left(Sheets(ws).Name, 4) >= StrtD And Left(Sheets(ws).Name, 4) <= EndD Then
        lrow = Sheets(ws).Cells(Rows.Count, 1).End(xlUp).Row
        For i = 2 To lrow
        On Error Resume Next
            If Not IsNull(WorksheetFunction.VLookup(Sheets(ws).Cells(i, 1), NewWs.Range(NewWs.Cells(2, 1).NewWs.Cells(2, 1).End(xlDown)), 1, False)) Then
                Sheets(ws).Rows(i).Copy Destination:=Rows(NewWs.Cells(Rows.Count, 1).End(xlUp).Row + 1)
                NewWs.Cells(Rows.Count, 1).End(xlUp).Offset(0, 7) = Left(Sheets(ws).Name, 4)
            End If
        Next i
    End If
Next ws
    
NewWs.Range(Rows(1), Rows(Cells(1, 1).End(xlDown).Row - 1)).Delete
NewWs.Range(Columns(1), Columns(7)).Sort Key1:=Range("A1"), Header:=xlYes


Application.ScreenUpdating = True
End Sub

Display More

Max1616 · Apr 28th 2016

Re: Fetching common (common company) data from different worksheets

I'm not sure why those lines are highlighted red in my code, but its working fine in the example workbook you provided.

Max1616 · Apr 28th 2016

Re: Fetching common (common company) data from different worksheets

Hello,

This allows you to enter your year range and then it does what you ask:

Code

Sub sannuk7()


Dim NewWs As Worksheet
Dim lrow As Long
Dim i As Long
Dim ws As Integer
Dim StrtD As Integer
Dim EndD As Integer
Dim Cell1 As Range


StrtD = Application.InputBox("Please insert start year", "Start Year", "2000")
EndD = Application.InputBox("Please insert end year", "End Year", Year(Now))


Application.ScreenUpdating = False


On Error Resume Next
Application.DisplayAlerts = False
Sheets("Summary").Delete
Application.DisplayAlerts = True




Set NewWs = Worksheets.Add(After:=Sheets(Sheets.Count))
NewWs.Name = "Summary"


For ws = 1 To Sheets.Count
    If Left(Sheets(ws).Name, 4) >= StrtD And Left(Sheets(ws).Name, 4) <= EndD Then
    Sheets(ws).Columns(1).Copy Destination:=NewWs.Columns(1)
    NewWs.Columns(1).RemoveDuplicates Columns:=1, Header:=xlYes
    NewWs.Range(Cells(2, 1).Address & ":" & Cells(1, 1).End(xlDown).Address).Copy Destination:=NewWs.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
    NewWs.Columns(1).ClearContents
    End If
    
Next ws


NewWs.Columns(2).RemoveDuplicates Columns:=1, Header:=xlNo




Set Cell1 = NewWs.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)


Cell1.Offset(1, -1) = "Symbol"
Cell1.Offset(1, 0) = "Company"
Cell1.Offset(1, 1) = "Director Salutation"
Cell1.Offset(1, 2) = "Director First Name"
Cell1.Offset(1, 3) = "Director Middle Name"
Cell1.Offset(1, 4) = "Director Surname"
Cell1.Offset(1, 5) = "Gender"


For ws = 1 To Sheets.Count
    If Left(Sheets(ws).Name, 4) >= StrtD And Left(Sheets(ws).Name, 4) <= EndD Then
        lrow = Sheets(ws).Cells(Rows.Count, 1).End(xlUp).Row
        For i = 2 To lrow
        On Error Resume Next
            If Not IsNull(WorksheetFunction.VLookup(Sheets(ws).Cells(i, 1), NewWs.Range(NewWs.Cells(2, 1).NewWs.Cells(2, 1).End(xlDown)), 1, False)) Then
                Sheets(ws).Rows(i).Copy Destination:=Rows(NewWs.Cells(Rows.Count, 1).End(xlUp).Row + 1)
            End If
        Next i
    End If
Next ws
    
NewWs.Range(Rows(1), Rows(Cells(1, 1).End(xlDown).Row - 1)).Delete
NewWs.Range(Columns(1), Columns(7)).Sort Key1:=Range("A1"), Header:=xlYes


Application.ScreenUpdating = True
End Sub

Display More

Let me know if you have any questions.

Sincerely,
Max

Max1616 · Apr 27th 2016

Re: SUM not working in certain cells only

Looks to me that your numbers are being read as text (type 2). You can add a 0 or multiply by 1 in order for it to force the text to be read as numbers and change it to type 1.