Posts by KjBox

KjBox · 2022-01-17T12:58:51+00:00

Try yhis

Code

Sub AddOne()
Dim r As Range
For Each r In ActiveSheet.UsedRange.Columns(1)
If IsNumeric(r) Then r = r + 1
Next
End Sub

KjBox · Saturday, 10:35 am

You're welcome

KjBox · Saturday, 8:56 am

You don't need line 6 of the code either. My amendment to your original code merely added an extra If..Then..End If statement to account for the current month being January. All you need to do is add your code for getting the previous month's data after each "Then".

KjBox · Thursday, 6:44 pm

Possibly something along these lines

Code

If Month(Date) > 1 Then
If Year(x(i, DtCol)) = Year(Date) And Month(x(i, DtCol)) = Month(Date) - 1 And x(i, 3) = ContAreas(ii) And x(i, 7) = Category And x(i, 8) = InspType Then
'Your code here
End If
ElseIf Year(x(i, DtCol)) = Year(Date) - 1 And Month(x(i, DtCol)) = 12 And x(i, 3) = ContAreas(ii) And x(i, 7) = Category And x(i, 8) = InspType Then
'Your code here
End If
End If

KjBox · Jan 2nd 2022

ok ty, Roy

KjBox · Jan 2nd 2022

Not sure if Roy is looking at this for you or not, I can if he isn't

KjBox · Dec 29th 2021

Try this.

My code will generate a string of Email recipients who meet the combo box criteria. That string can then be parsed to your emailing code to be used in the "To" bit of the code (.To sTo)

Code

Option Explicit
Sub Email_Recipients()
Dim x, i As Long, sS As String, sP As String, sRecps As String
x = Sheet2.Cells(1).CurrentRegion
sS = Sheet1.cbSubject: sP = Sheet1.cbPriority
For i = 2 To UBound(x, 1)
If x(i, 3) = sP And x(i, 9) = sS Then
If sRecps <> "" Then sRecps = sRecps & x(i, 5) Else sRecps = x(i, 5)
End If
Next
If Len(sRecps) Then Send_Email_Excel_Attachment_Early_Binding sRecps
End Sub
Sub Send_Email_Excel_Attachment_Early_Binding(sTo As String)
MsgBox "I will write code for outlook here"
End Sub

Display More

KjBox · Dec 28th 2021

Try the attached.

On Sheet 1 the cell linked to the List Box is E2, The list of weekdays starting in J2 is used to populate the list box (you can move it anywhere, even to a hidden sheet, it is a named range "Days". That named range is also used in the code.

The code assigned to the ListBox is

Code

Sub ListBox_Change()
Const lRow As Long = 7
Dim lCol As Long
With Sheet2
lCol = .Cells(lRow, .Columns.Count).End(xlToLeft).Column
If Len(.Cells(lRow, lCol)) Then lCol = lCol + 1
.Cells(lRow, lCol) = [Days].Rows([e2])
.Activate
End With
Sheet1.[e2] = 0
End Sub

Display More

KjBox · Dec 27th 2021

The code will depend upon whether you are using a Form Control Listbox or an ActiveX one. Attach your workbook

KjBox · Dec 21st 2021

Alternatively try the attached, click the button on Sheet 1.

Code assigned to the button:

Code

Sub OrganiseData()
Dim x, y, i As Long, ii As Long, iii As Long
x = Sheet1.Cells(1).CurrentRegion
ReDim y(1 To UBound(x, 1) / 8, 1 To 8)
For i = 1 To UBound(x, 1) Step 8
ii = ii + 1: iv = i - 1
For iii = 1 To 8
y(ii, iii) = x(iii, 1)
Next
Next
With Sheet2
.Cells(1).CurrentRegion.Clear
With .[a1].Resize(UBound(y, 1), 8)
.Value = y
With .Columns(5).Resize(, 2)
.NumberFormat = "h:mm"
.HorizontalAlignment = -4131
End With
.Columns(8).Font.Color = RGB(107, 165, 58)
End With
.Activate
.Columns.AutoFit
Application.Goto .[a1]
End With
End Sub

Display More

KjBox · Dec 21st 2021

Why is Row 1 of Sheet1 like it is?

KjBox · Dec 17th 2021

Like this

Code

Sub Transfer_Comments()
Dim x, y, i As Long, ii As Long
x = Sheets("Base").Cells(1).CurrentRegion
y = Sheets("Comment").Cells(1).CurrentRegion
For i = 1 To UBound(x, 1)
For ii = 1 To UBound(y, 1)
If x(i, 11) = y(ii, 11) And x(i, 14) = y(ii, 14) Then
x(i, 22) = y(ii, 22)
Exit For
End If
Next
Next
Sheets("Base").Cells(1).CurrentRegion = x
Application.DisplayAlerts = 0
Sheets("Comment").Delete
Application.DisplayAlerts = 0
End Sub

Display More

KjBox · Dec 15th 2021

Does the folder specified in "newFullPath" always exist, and is it in the same folder as "ThisWorkbook"?

KjBox · Dec 15th 2021

Try this

Code

Sub Transfer_Comments()
Dim x, y, i As Long, ii As Long
x = Sheets(1).Cells(1).CurrentRegion
y = Sheets(2).Cells(1).CurrentRegion
For i = 1 To UBound(x, 1)
For ii = 1 To UBound(y, 1)
If x(i, 11) = y(ii, 11) And x(i, 14) = y(ii, 14) Then
x(i, 22) = y(ii, 22)
Exit For
End If
Next
Next
Sheets(1).Cells(1).CurrentRegion = x
Application.DisplayAlerts = 0
Sheets(2).Delete
Application.DisplayAlerts = 0
End Sub

Display More

KjBox · Dec 15th 2021

Try changing

Code

newFullPath = WBPath & "\" & WBName
ThisWorkbook.SaveAs fileName:=CustomerName & "_" & PricingAnalysis & "_" & Format(Date, "MM.DD.YYYY") & ".xlsm"

to

Code

newFullPath = WBPath & "\" & WBName & "\"
ThisWorkbook.SaveAs fileName:=newFullPath & CustomerName & "_" & PricingAnalysis & "_" & Format(Date, "MM.DD.YYYY") & ".xlsm"

KjBox · Dec 15th 2021

Can any values in Sheet1 column A and column N have more than one match in Sheet 2 column A and column N?

KjBox · Oct 10th 2021

You're welcome

KjBox · Oct 10th 2021

Try this alternative approach, file attached

Code assigned to the button

Code

Option Explicit
Sub DeleteRows()
Dim x, i As Long, ii As Long
With Sheet1.Cells(1).CurrentRegion
x = .Value
For i = 2 To UBound(x, 1)
If Application.CountIf(.Columns(6), x(i, 6)) > 1 Then
ii = i + 1
Do Until ii = UBound(x, 1) + 1
If x(ii, 6) = x(i, 6) And x(ii, 10) + x(i, 10) = 0 Then
x(i, 1) = vbNullString: x(ii, 1) = vbNullString
Exit Do
End If
ii = ii + 1
Loop
End If
Next
.Value = x
On Error Resume Next
.Columns(1).SpecialCells(4).EntireRow.Delete
End With
End Sub

Display More

KjBox · Sep 26th 2021

CurrentRegion stops at an empty row, so the "Record Only" would not be included. Try

Code

Sub DeleteRows()
Dim x, i As Long, lRow As Long
With Sheet1
lRow = .Cells(.Rows.Count, 4).End(xlUp).Row
x = .Cells(2, 4).Resize(lRow)
For i = UBound(x, 1) To 1 Step -1
If x(i, 4) = "Record Only" Then
.Rows(i).Resize(16).Delete
End If
Next
End With
End Sub

Display More

KjBox · Sep 26th 2021

Try this

Code

Sub DeleteRows()
Dim x, i As Long
x = Sheet1.Cells(1).CurrentRegion
For i = UBound(x, 1) To 2 Step -1
If x(i, 4) = "Record Only" Then
Sheet1.Rows(i).Resize(16).Delete
End If
Next
End Sub

Display More

Posts by KjBox

Adding one to the previous number in the column

Previous month code

Previous month code

Previous month code

Write Formula for Supply Chain Visualization Sheet - $30

Write Formula for Supply Chain Visualization Sheet - $30

using Activex comboxbox to trigger respective action

vba code to copy list box contents

vba code to copy list box contents

Help with creating VBA to clean up and organize some data

Help with creating VBA to clean up and organize some data

Transfer Data Loop

Not saving correctly

Transfer Data Loop

Not saving correctly

Transfer Data Loop

VBA Macro Macro for deleting rows with same reference and opposite signs

VBA Macro Macro for deleting rows with same reference and opposite signs

VBA Delete Entire Row if Contains Certain Text

VBA Delete Entire Row if Contains Certain Text