Posts by Raha

Sub Test()
    Dim SL As Object, A As Variant, i As Long
    
    Set SL = CreateObject("system.collections.sortedlist")
    With Sheets("Sandvik US Price List").Cells(1).CurrentRegion
        A = .Value
        For i = 2 To UBound(A, 1)
            If Not SL.contains(A(i, 1)) Then
                SL.Item(A(i, 1)) = VBA.Array(A(i, 2), A(i, 3))
            End If
        Next
    End With
    
    With Sheets("Sheet2").Cells(12, 1).CurrentRegion
        A = .Value
        .ClearContents
        For i = 2 To UBound(A, 1)
            If SL.contains(A(i, 2)) Then
                A(i, 4) = SL(A(i, 2))(0): A(i, 5) = SL(A(i, 2))(1)
            Else
                A(i, 5) = "For quotation"
            End If
        Next
        .Value = A
    End With
End Sub

Sub print_JPG()
    Dim Nm As Range, Acct As String
    With Sheets("pic_format")
        .Activate
        Acct = .Range("A4").Value
        Set Nm = .Range("A1:F8")
        Nm.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
        With .ChartObjects.Add(Left:=Nm.Left, Top:=Nm.Top, Width:=Nm.Width, Height:=Nm.Height)
            .Name = "TempArea"
            .Activate
            ActiveChart.Paste
            .Parent.ChartObjects("TempArea").Chart.Export "D:\" & Acct & ".jpg"
            .Parent.ChartObjects("TempArea").Delete
        End With
    End With
End Sub

Sub test()
    Dim A As Variant, i As Long, dic As Object, n As Long, y As Variant, Nm As Range, e As Variant, sht As Worksheet




    Set dic = CreateObject("Scripting.dictionary")
    A = Worksheets("sales").Cells(1).CurrentRegion.Value




    For i = 2 To UBound(A, 1)
        If Not dic.exists(A(i, 1)) Then
            Set dic(A(i, 1)) = CreateObject("Scripting.dictionary")
        End If
        If Not dic(A(i, 1)).exists(A(i, 2)) Then
            dic(A(i, 1))(A(i, 2)) = VBA.Array(A(i, 1), A(i, 2), A(i, 3), A(i, 4), Empty)
        Else
            w = dic(A(i, 1))(A(i, 2))
            w(3) = w(3) + A(i, 4)
            dic(A(i, 1))(A(i, 2)) = w
        End If
    Next




    A = Worksheets("outstanding").Cells(1).CurrentRegion.Value
    For i = 2 To UBound(A, 1)
        If dic.exists(A(i, 1)) Then
            If dic(A(i, 1)).exists(A(i, 2)) Then
                w = dic(A(i, 1))(A(i, 2))
                w(4) = w(4) + A(i, 4)
                dic(A(i, 1))(A(i, 2)) = w
            End If
        End If
    Next
    
    On Error Resume Next
    Set sht = Sheets("Test")
    If sht Is Nothing Then
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Test"
        Set sht = Sheets("Test")
    End If
    
    y = dic.items
    With Sheets("summary")
        .Activate
        .Cells(4, 1).CurrentRegion.Offset(1).ClearContents
        For i = 0 To dic.Count - 1
            With .Cells(5, 1).Offset(n).Resize(y(i).Count, 5)
                .Value = Application.Transpose(Application.Transpose(y(i).items))
            End With
            n = n + y(i).Count
        Next
        .Cells(4, 1).CurrentRegion.Borders.Weight = 2
        For Each e In dic.keys()
            .Range("A4:E" & .Range("A" & .Rows.Count).End(xlUp).Row).AutoFilter 1, e
            On Error Resume Next
            Set Nm = .AutoFilter.Range.Offset(0, 0).Resize(.AutoFilter.Range.Rows.Count, .AutoFilter.Range.Columns.Count) _
            .SpecialCells(xlCellTypeVisible)
            Nm.Copy sht.Range("A1")
            With sht
                .Activate
                .Range("A1").CurrentRegion.Columns.AutoFit
                Set Nm = .Range("A1").CurrentRegion
                Nm.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
                With .ChartObjects.Add(Left:=Nm.Left, Top:=Nm.Top, Width:=Nm.Width, Height:=Nm.Height)
                    .Name = "TempArea"
                    .Activate
                    ActiveChart.Paste
                    .Parent.ChartObjects("TempArea").Chart.Export "D:\" & e & ".jpg"
                    .Parent.ChartObjects("TempArea").Delete
                End With
                .Range("A1").CurrentRegion.ClearContents
            End With
        Next
        .AutoFilterMode = False
    End With
    Application.DisplayAlerts = False
        sht.Delete
        Sheets("summary").Activate
    Application.DisplayAlerts = True
End Sub

Option Explicit
Sub Test(dic As Object)
    Dim A As Variant, i As Long
    A = Sheets("Sheet2").Cells(1).CurrentRegion.Value
    For i = 2 To UBound(A, 1)
        If Not dic.exists(A(i, 1)) Then
            dic.Item(A(i, 1)) = VBA.Array(A(i, 2), A(i, 3))
        End If
    Next
End Sub




Private Sub Worksheet_Change(ByVal Target As Range)
    Dim dic As Object
    Application.EnableEvents = False
    If Not Target Is Nothing And Target.Address = Sheets("Sheet1").Range("C3").Address Then
        Set dic = CreateObject("Scripting.dictionary"): Test dic
        If dic.exists(Target.Value) Then
            Range("C4").Value = dic.Item(Target.Value)(0)
            Range("C5").Value = dic.Item(Target.Value)(1)
        End If
    End If
    Application.EnableEvents = True
End Sub

Sub test()
    Dim A As Variant, i As Long, dic As Object, n As Long, y As Variant
    
    Set dic = CreateObject("Scripting.dictionary")
    A = Worksheets("sales").Cells(1).CurrentRegion.Value
    
    For i = 2 To UBound(A, 1)
        If Not dic.exists(A(i, 1)) Then
            Set dic(A(i, 1)) = CreateObject("Scripting.dictionary")
        End If
        If Not dic(A(i, 1)).exists(A(i, 2)) Then
            dic(A(i, 1))(A(i, 2)) = VBA.Array(A(i, 1), A(i, 2), A(i, 3), A(i, 4), Empty)
        Else
            w = dic(A(i, 1))(A(i, 2))
            w(3) = w(3) + A(i, 4)
            dic(A(i, 1))(A(i, 2)) = w
        End If
    Next
    
    A = Worksheets("outstanding").Cells(1).CurrentRegion.Value
    For i = 2 To UBound(A, 1)
        If dic.exists(A(i, 1)) Then
            If dic(A(i, 1)).exists(A(i, 2)) Then
                w = dic(A(i, 1))(A(i, 2))
                w(4) = w(4) + A(i, 4)
                dic(A(i, 1))(A(i, 2)) = w
            End If
        End If
    Next
    
    y = dic.items
    With Sheets("summary")
        .Cells(4, 1).CurrentRegion.Offset(1).ClearContents
        For i = 0 To dic.count - 1
            With .Cells(5, 1).Offset(n).Resize(y(i).count, 5)
                .Value = Application.Transpose(Application.Transpose(y(i).items))
            End With
            n = n + y(i).count
        Next
        .Cells(4, 1).CurrentRegion.Borders.Weight = 2
    End With
End Sub

Sub Test()
    Dim Rng As Range, A As Variant, e As Variant, sht As Worksheet, n As Long, i As Long
    
    On Error Resume Next
    Set sht = ThisWorkbook.Sheets("Dispatch_load")
    If sht Is Nothing Then
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Dispatch_load"
    End If
    
    n = 10: i = 0
    With Sheets("AMC Agent Breakout")
        .Activate
        For Each e In Array("KAX0", "KAX1", "KAX2", "KAX3", "KAX4", "KAX5", "KAX6", "KAX7", "KAX8", "KAX9")
            .Range("A1:R" & .Range("A" & .Rows.Count).End(xlUp).Row).AutoFilter Field:=8, Criteria1:=e
            .Range("A1:R" & .Range("A" & .Rows.Count).End(xlUp).Row).AutoFilter Field:=18, Criteria1:="0"
            Set Rng = .AutoFilter.Range.Offset(1, 0).Resize(.AutoFilter.Range.Rows.Count - 1, .AutoFilter.Range.Columns.Count) _
            .SpecialCells(xlCellTypeVisible)
            
            If Not Rng Is Nothing Then
                On Error Resume Next
                Set sht = ThisWorkbook.Sheets("Agent&DRM")
                If sht Is Nothing Then
                    Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Agent&DRM"
                End If
                With Sheets("Agent&DRM")
                    .Activate
                    .UsedRange.Clear
                    ' Added to clear the existing data
                    Rng.Copy .Range("C6")
                    .Columns("C:I").Delete Shift:=xlToLeft
                    .Columns("D:J").Delete Shift:=xlToLeft
                    .Columns("E:F").Delete Shift:=xlToLeft
                    .Range("T17").FormulaR1C1 = "AAX" & i
                    .Range("U17").FormulaR1C1 = "=SUM(R[-11]C[-17]:R[8983]C[-17])"
                    .Range("T17:U17").Copy
                    Sheets("Dispatch_load").Range("A" & n).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                End With
            n = n + 1: i = i + 1
            End If
            .AutoFilterMode = False
            Set Rng = Nothing
            ' added to release the memory
        Next
    End With
End Sub