Posts by KjBox

**KjBox** · Jun 16th 2022

Try this

Code

Dim lastRow As Long
Dim sheetName As String

    sheetName = "Main Report"
    lastRow = Sheets(sheetName).Range("D" & Rows.Count).End(xlUp).Row
    
    For lRow = 6 To lastRow

        If Sheets(sheetName).Cells(lRow, "D") = Sheets(sheetName).Cells(lRow, "F") Then
            Sheets(sheetName).Cells(4, 6).CurrentRegion.Rows(lRow).Interior.ColorIndex = 3
        End If

    Next lRow

Display More

You may need to use .Rows(lRow + 1) as you do not say if you have a header row, or what is in rows 1 to 5

**KjBox** · Jun 15th 2022

Attach a sample workbook

**KjBox** · Jun 15th 2022

Try this

Code

Option Explicit

Sub SubtractEvery2Rows()
    Dim x, y, i&, ii&, iii&, ws As Excel.Worksheet
    
    For Each ws In ThisWorkbook.Sheets
        With ws
            iii = 0
            x = .Cells(1).CurrentRegion
            ReDim y(1 To UBound(x, 1) + (UBound(x, 1) / 2), 1 To UBound(x, 2))
            For i = 2 To UBound(x, 1)
                iii = iii + 1
                For ii = 1 To UBound(x, 2)
                    y(iii, ii) = x(i, ii)
                Next
                If (i - 1) Mod 2 = 0 Then
                    iii = iii + 1
                    y(iii, 1) = x(i, 1) - x(i - 1, 1)
                End If
            Next
            .Cells(1).CurrentRegion.Offset(1).Clear
            .Cells(2, 1).Resize(iii, UBound(y, 2)) = y
            .Cells(1).CurrentRegion.Columns(1).HorizontalAlignment = xlLeft
        End With
    Next
            
End Sub

Display More

**KjBox** · Jun 12th 2022

This should get you started

Code

Sub ExtractFTs()
    Dim x, i&, s$
    
    x = Split(ActiveCell, ", ")
    For i = LBound(x) To UBound(x)
        If x(i) Like "FT*" Then
            If s = vbNullString Then
                s = x(i)
            Else
                s = s & ", " & x(i)
            End If
        End If
    Next
    MsgBox s
    
End Sub

Display More

**KjBox** · Jun 12th 2022

Maybe

Code

Sub MatchText()
    Dim x, y, i&
    x = Sheets("Cabinets").Columns(29)
    y = Sheets("Cabinets").Columns(35)
    
    With Sheets("Edging")
        s = .Cells(1, 1)
        If Not IsError(Application.Match(.Cells(1, 1), x, 0)) Then
            i = Application.Match(.Cells(1, 1), x, 0)
            .Cells(1, 2) = y(i, 1)
        Else
            MsgBox "No match found", 64, "Matching Text"
        End If
    End With
    
End Sub

Display More

**KjBox** · Jun 9th 2022

You're welcome

**KjBox** · Jun 8th 2022

Try changing the "UpdateAllFiles" procedure to:

Code

Sub UpdateAllFiles()
    Dim fName, wbk As Workbook, ws As Worksheet, i&, lCnt&, sFile$
    Dim dtE As Date, dtS As Date, sType$, sDtOrd$, sOut$, StatBar
    
    dtE = [EndDate]: dtS = [StartDate]: sType = [DataType]
    sDtOrd = [DateOrder]: sOut = [OutputType]
    
    fName = Dir("C:\Users\charl\Desktop\Akhas\") 'CHANGE this to the path to your folder
    
    ' Get current StatusBar info
    StatBar = Application.StatusBar
    
    'Get count of files in the folder
    While (fName <> "")
        i = i + 1
        fName = Dir
    Wend
    
    ' Reset fName
    fName = Dir("C:\Users\charl\Desktop\Akhas\") 'CHANGE this to the path to your folder
    
    Application.ScreenUpdating = 0
    ii = 0: lCnt = 0
    While fName <> ""
        lCnt = lCnt + 1
        Set wbk = Workbooks.Open(fName)
        Set ws = wbk.Sheets("Historical")
        sFile = fName
        With ws
            .Activate
            Call HistoricalData(sType, dtS, dtE, sDtOrd, sOut, sFile)
            
            ' Enter the information used to create the table
            .[EndDate] = dtE: .[StartDate] = dtS: .[DataType] = sType
            .[DateOrder] = sDtOrd: .[OutputType] = sOut
            
            'Save and close the workbook
            .Parent.Close 1
        End With
        
        ' Pause for 5 minutes every 25 files
        If lCnt = 25 Then
            Application.StatusBar = ii & " of " & i & " files updated, waiting for Yahoo."
            Application.Wait Now + TimeValue("0:05:00")
            lCnt = 0
        End If
        
        ' Show progress in Status Bar
        Application.StatusBar = ii & " of " & i & " files updated"
        
        fName = Dir
    Wend
    
    MsgBox ii & " Files out of " & i & " have beed updated", 64, "Historical Data Update"
    Application.StatusBar = StatBar
    
End Sub

Display More

I have included a "Progress Status" message that will show in your Status Bar

**KjBox** · Jun 7th 2022

You're welcome

**KjBox** · Jun 5th 2022

You're welcome

**KjBox** · Jun 4th 2022

Try Option Explicit instead of Options Explicit

**KjBox** · Jun 1st 2022

Got it, I will review it and get back to you with any queries.

**KjBox** · Jun 1st 2022

PM sent with my email address

**KjBox** · Jun 1st 2022

I can look at this for you

**KjBox** · May 25th 2022

Sorry, missed that. Try

Code

Private Sub Worksheet_Change(ByVal Target As Range)
    With Target
        If .Count > 1 Then Exit Sub
        If .Column = 15 Then
            .ClearComments
            .AddComment "Recepcionado el: " & Format(Date, "long date") & " por: " & Application.UserName
            .Comment.Visible = 1
        ElseIf .Column = 16 Then
            .ClearComments
            .AddComment "Confirmado el: " & Format(Date, "long date") & " por: " & Application.UserName
            .Comment.Visible = 1
        End If
    End With
End Sub

Display More

**KjBox** · May 24th 2022

Try

Code

Private Sub Worksheet_Change(ByVal Target As Range)
    With Target
        If .Count > 1 Then Exit Sub
        If .Column = 15 Or .Column = 16 Then
            .ClearComments
            .AddComment "Recepcionado el " & Format(Date, "long date") & " por: " & Application.UserName
            .Comment.Visible = 1
        End If
    End With
End Sub

**KjBox** · May 23rd 2022

Without knowing what changes Yahoo has made, if any, I cannot make any correction to the code.

**KjBox** · May 22nd 2022

Here is the code with some comments to help you understand what does what.

Code

Option Explicit

Sub Summary()
    Dim x, y, z, months, i&, ii&, lColD&, lColP&, lColQ&, lCol&, oDic As Object
    
' Place months in required order into an array (months)
    months = Array("April", "May", "June", "July", "August", "September", _
                "October", "November", "December", "January", "February", "March")

' Get the column numbers for Date, Product and Quantity
    lColD = Application.Match("Date", Sheet1.Rows(1), 0)
    lColP = Application.Match("Products", Sheet1.Rows(1), 0)
    lColQ = Application.Match("Quantity", Sheet1.Rows(1), 0)
    Set oDic = CreateObject("scripting.dictionary")
    
' Load all Input data into array x
    x = Sheet1.Cells(1).CurrentRegion
    
' Loop through array x and us scripting dictionary to get a liast of unique products
' Load that lis into array z
    With oDic
        For i = 2 To UBound(x, 1)
            If Not .exists(x(i, lColP)) Then .Add x(i, lColP), Nothing
        Next
        z = .keys
    End With
    
' Redim y to suit number of products (plus Header and Total rows)
    ReDim y(1 To oDic.Count + 2, 1 To 15)
    
' Load array y with required headers
    y(1, 1) = "S.No": y(1, 2) = "Products": y(1, 15) = "Product Totals"
    For i = 3 To 14
        y(1, i) = months(i - 3)
    Next
    
' Loop through array y and load with S.No and Product
    For i = 2 To UBound(y, 1)
        y(UBound(y, 1), 2) = "Monthly Totals"
        If i - 3 < UBound(z) Then y(i, 1) = i - 1: y(i, 2) = z(i - 2)
        
    ' Loop through array x and get Quantity for each Product
    ' Update Product and Monthly totals
        For ii = 2 To UBound(x, 1)
            If x(ii, lColP) = y(i, 2) Then
                lCol = Application.Match(MonthName(Month(x(ii, lColD)), 0), months, 0) + 2
                y(i, lCol) = y(i, lCol) + x(ii, lColQ)
                y(i, 15) = y(i, 15) + x(ii, lColQ)
                y(UBound(y, 1), lCol) = y(UBound(y, 1), lCol) + x(ii, lColQ)
                y(UBound(y, 1), 15) = y(UBound(y, 1), 15) + x(ii, lColQ)
            End If
        Next
    Next
    
' Load the contents of array y onto the Output sheet (after clear anything there)
' Add required formatting to Output data
    With Sheet2
        .UsedRange.Clear
        .[a1] = "Summary": .[a1].Font.Bold = 1
        With .[a2].Resize(UBound(y, 1), 15)
            .Value = y
            .Borders.Weight = 2
            .Columns(1).Font.Bold = 1
            .Columns(2).Font.Bold = 1
            .Columns(15).Font.Bold = 1
            .Rows(1).Font.Bold = 1
            .Rows(.Rows.Count).Font.Bold = 1
            .Columns.AutoFit
        End With
        .Activate
    End With
    
End Sub

Display More

**KjBox** · May 22nd 2022

You're welcome

**KjBox** · May 22nd 2022

Try the attached file. Click the button on the Input sheet.

Code assigned to the button:

Code

Option Explicit

Sub Summary()
    Dim x, y, z, months, i&, ii&, lColD&, lColP&, lColQ&, lCol&, oDic As Object
    
    months = Array("April", "May", "June", "July", "August", "September", _
                "October", "November", "December", "January", "February", "March")
    lColD = Application.Match("Date", Sheet1.Rows(1), 0)
    lColP = Application.Match("Products", Sheet1.Rows(1), 0)
    lColQ = Application.Match("Quantity", Sheet1.Rows(1), 0)
    Set oDic = CreateObject("scripting.dictionary")
    x = Sheet1.Cells(1).CurrentRegion
    With oDic
        For i = 2 To UBound(x, 1)
            If Not .exists(x(i, lColP)) Then .Add x(i, lColP), Nothing
        Next
        z = .keys
    End With
    ReDim y(1 To oDic.Count + 2, 1 To 15)
    y(1, 1) = "S.No": y(1, 2) = "Products": y(1, 15) = "Product Totals"
    For i = 3 To 14
        y(1, i) = months(i - 3)
    Next
    For i = 2 To UBound(y, 1)
        y(UBound(y, 1), 2) = "Monthly Totals"
        If i - 3 < UBound(z) Then y(i, 1) = i - 1: y(i, 2) = z(i - 2)
        For ii = 2 To UBound(x, 1)
            If x(ii, lColP) = y(i, 2) Then
                lCol = Application.Match(MonthName(Month(x(ii, lColD)), 0), months, 0) + 2
                y(i, lCol) = y(i, lCol) + x(ii, lColQ)
                y(i, 15) = y(i, 15) + x(ii, lColQ)
                y(UBound(y, 1), lCol) = y(UBound(y, 1), lCol) + x(ii, lColQ)
                y(UBound(y, 1), 15) = y(UBound(y, 1), 15) + x(ii, lColQ)
            End If
        Next
    Next
    With Sheet2
        .UsedRange.Clear
        .[a1] = "Summary": .[a1].Font.Bold = 1
        With .[a2].Resize(UBound(y, 1), 15)
            .Value = y
            .Borders.Weight = 2
            .Columns(1).Font.Bold = 1
            .Columns(2).Font.Bold = 1
            .Columns(15).Font.Bold = 1
            .Rows(1).Font.Bold = 1
            .Rows(.Rows.Count).Font.Bold = 1
            .Columns.AutoFit
        End With
        .Activate
    End With
    
End Sub

Display More

**KjBox** · May 22nd 2022

Post the code you have done so far.

Posts by KjBox

VBA - Highlight Entire Row - Based on Duplicate

How to pull specific cells from SAP MD04 using VBA?

Insert Row Every Two Rows and Subtract the Difference

VBA to select specific words from a string

Search for text in a column, copy the text in the same row different column, paste to different sheet

Open Multiple XLSM files from a given Folder

Open Multiple XLSM files from a given Folder

Review/critique/offer suggestions to skydive logbook - US $56

options explicit error

options explicit error

Review/critique/offer suggestions to skydive logbook - US $56

Review/critique/offer suggestions to skydive logbook - US $56

Review/critique/offer suggestions to skydive logbook - US $56

combine two worksheet_change

combine two worksheet_change

Open Multiple XLSM files from a given Folder

Data list summary-2D array

Data list summary-2D array

Data list summary-2D array

Data list summary-2D array