Posts by KjBox

KjBox · Mar 25th 2020

You're welcome

KjBox · Mar 22nd 2020

Payment received, many thanks.

File sent as PM

KjBox · Mar 22nd 2020

I have a solution for you.

I will PM you my PayPal details and post the file here upon receipt of payment.

KjBox · Mar 22nd 2020

Your sample Destination sheet shows just "Scenario 1".

Where should "Scenario 2" be placed?

To the right of Scenario 1? If so then should it begin in G1 or H1 (i.e. should each scenario be separated by an empty column?
Below Scenario 1? If so then should it begin in A24 or A25 (i.e. should each scenario be separated by an empty row?

KjBox · Mar 22nd 2020

I can look at this for you

KjBox · Mar 11th 2020

Revised code with error trapping sent via PM

KjBox · Mar 11th 2020

Revised code sent via PM

KjBox · Mar 11th 2020

Got it, thanks, testing now

KjBox · Mar 11th 2020

Don't worry about the Data/Pivot file without the query, I have done that, but I still need the images to conduct a proper test.

KjBox · Mar 11th 2020

What error do you get, and on which line of code?

It all works for me, but then I had to hard code for the path to a picture.

I could not update the paths in the data table because then refreshing the pivot caused an error because the power query tried to refresh too, but of course it could not.

Could you send me a file containing all the images you have links to in the data table, and remove the power query from the data/pivot file.

I can then do a full test of the code.

KjBox · Mar 10th 2020

Try

Code

Sub SNREPORT()
Dim x, i As Long, ii As Long
With Sheets(1).Cells(1).CurrentRegion
With .Offset(1).Resize(.Rows.Count - 1)
x = .Value2
For i = 1 To UBound(x, 1)
x(i, 10) = Replace(Replace(Replace(LCase(Trim(x(i, 10))), " x", vbNullString), ".", vbNullString), "null", vbNullString)
x(i, 13) = Replace(Replace(x(i, 13), " x", vbNullString), ".", vbNullString)
x(i, 24) = Trim(x(i, 24))
x(i, 15) = Right(Trim(x(i, 15)), 4)
x(i, 24) = IIf(Trim(x(i, 24)) = "", "Verify Title", _
IIf(LCase(Trim(x(i, 24))) = "n/a - not applicable", "Verify Title", x(i, 24)))
x(i, 27) = Replace(Trim(x(i, 27)), " 1101 Maine Street", vbNullString)
If Right(Trim(x(i, 27)), 3) = "HOS" Then
x(i, 27) = Replace(x(i, 27), "HOS", "HOSPITAL")
ElseIf Right(Trim(x(i, 27)), 4) = "HOSP" Then
x(i, 27) = Replace(x(i, 27), "HOSP", "HOSPITAL")
End If
x(i, 28) = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(LCase(x(i, 28)), _
"street", "ST"), "road", "RD"), "drive", "DR"), "parkway", "PKWY"), ".", ""), "avenue", "AVE"), "suite", "STE"), _
"north", "N"), "south", "S"), "west", "W"), "east", "E"), "court", "CRT")
Next
.Value2 = x
For ii = 1 To UBound(x, 2)
.Columns(ii).NumberFormat = IIf(ii = 15, "0000", "General")
Next
End With
Application.Goto .Parent.[a1]
End With
End Sub

Display More

KjBox · Mar 10th 2020

Payment received and code sent by PM

KjBox · Mar 10th 2020

I have a solution ready, will PM you my PayPal details

KjBox · Mar 10th 2020

I can have a look at this for you

KjBox · Mar 10th 2020

Do you mean that the SSN can start off as more that a 4 digit number, and you need only the last 4 digits to display with all zeros that may be present in those last 4 digits?

It would be best if you could give me some examples of what the SSN entries could be.

KjBox · Mar 9th 2020

Which code did you decide to use?

Which column is the SSN column?

Can you give a few examples of the data that could be in that column.

KjBox · Mar 8th 2020

If you are importing data from an external source then Power Query would be even better than SQL

KjBox · Mar 8th 2020

Didn't really expect Target.Row to make a difference in speed, it was just a better way of coding.

KjBox · Mar 8th 2020

A loop-less solution is possible, but because it has to be an object based code that has to make calls to the worksheet for each "Replacement". Also with object based code it is not possible to combine multiple "Replace" functions into a single line of code and have it case insensitive.

An alternative is to use a single For....Next loop with an array based code.

I am attaching 2 files with the same data, one uses the loop-less code and the other the array looping code.

Personally I think the array based looping code is preferable. Not only is it likely to be slightly faster (depends on the number of rows of data), it is also more versatile for any future changes.

Codes assigned to the buttons are:

Loop-less:

Code

Sub SNREPORT()
With Sheets(1).Cells(1).CurrentRegion
With .Offset(1).Resize(.Rows.Count - 1)
Application.ScreenUpdating = 0
With .Columns(10)
.Replace " null", "": .Replace " x", "": .Replace ".", ""
End With
With .Columns(13)
.Replace " x", "": .Replace ".", ""
End With
.Replace " null", "": .Replace " x", "": .Replace ".", ""
With .Columns(24)
.Replace " ", "Verify Title": .Replace "", "Verify Title"
.Replace "n/a - not applicable", "Verify Title"
End With
With .Columns(27)
.Replace "Quincy Medical Group 1101 Maine Street", "Quincy Medical Group"
.Replace "ROCK ISLAND TRINITY WEST HOSP", "ROCK ISLAND TRINITY WEST HOSPITAL"
.Replace "ANAMOSA JONES REGIONAL MED HOS", "ANAMOSA JONES REGIONAL MED HOSPITAL"
.Replace "ROCK ISLAND TRINITY WEST HOSP", "ROCK ISLAND TRINITY WEST HOSPITAL"
End With
With .Columns(28)
.Replace "street", "ST": .Replace "road", "RD": .Replace "drive", "DR": .Replace "parkway", "PKWY"
.Replace "avenue", "AVE": .Replace "court", "CRT": .Replace "suite", "STE"
.Replace "north", "N": .Replace "south", "S": .Replace "east", "E": .Replace "west", "W"
End With
.NumberFormat = "General"
.Value = Application.Trim(.Value)
End With
Application.Goto .Parent.[a1]
Application.ScreenUpdating = 0
End With
End Sub

Display More

Array loop:

Code

Sub SNREPORT()
With Sheets(1).Cells(1).CurrentRegion
With .Offset(1).Resize(.Rows.Count - 1)
x = .Value2
For i = 1 To UBound(x, 1)
x(i, 10) = Replace(Replace(Replace(LCase(Trim(x(i, 10))), " x", vbNullString), ".", vbNullString), "null", vbNullString)
x(i, 13) = Replace(Replace(x(i, 13), " x", vbNullString), ".", vbNullString)
x(i, 24) = Trim(x(i, 24))
x(i, 24) = IIf(Trim(x(i, 24)) = "", "Verify Title", _
IIf(LCase(Trim(x(i, 24))) = "n/a - not applicable", "Verify Title", x(i, 24)))
x(i, 27) = Replace(Trim(x(i, 27)), " 1101 Maine Street", vbNullString)
If Right(Trim(x(i, 27)), 3) = "HOS" Then
x(i, 27) = Replace(x(i, 27), "HOS", "HOSPITAL")
ElseIf Right(Trim(x(i, 27)), 4) = "HOSP" Then
x(i, 27) = Replace(x(i, 27), "HOSP", "HOSPITAL")
End If
x(i, 28) = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(LCase(x(i, 28)), _
"street", "ST"), "road", "RD"), "drive", "DR"), "parkway", "PKWY"), ".", ""), "avenue", "AVE"), "suite", "STE"), _
"north", "N"), "south", "S"), "west", "W"), "east", "E"), "court", "CRT")
Next
.Value2 = x
.NumberFormat = "General"
End With
Application.Goto .Parent.[a1]
End With
End Sub

Display More

Note that in both cases I have applied "General" format to the entire data range, that is to replace all Text formatting, which is a problem waiting to happen and should be avoided whenever possible.

KjBox · Mar 7th 2020

Hi, welcome to Ozgrid!

When posting code you must place it in a "Code box". To do so, copy your code, then click the "</>" icon in the reply box menu bar, and paste code into the code box that will appear. I have done this for you in this instance.

As for your code.

Using "If......ElseIf.......End If" statements is far more than separate "If.....End If" statements even with End in each If statement, but better still is "Select Case.....Case....End Select"

I have modified your first code to use Select case

Code

Option Explicit
Dim PageBreakState As Boolean
Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("C3:C100")) Is Nothing Then
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
PageBreakState = ActiveSheet.DisplayPageBreaks
ActiveSheet.DisplayPageBreaks = False
Select Case Target.Value2
Case "+"
Select Case Cells(Target.Row, 16).Value2
Case "C": Show_Details_Top_Level Target.Row
Case "N": Show_Transactions_Top_Level Target.Row
End Select
Case "-"
Select Case Cells(Target.Row, 16).Value2
Case "C": Hide_Details_Top_Level Target.Row
Case "N": Hide_Transactions_Top_Level Target.Row
End Select
End Select
End Select
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
ActiveSheet.DisplayPageBreaks = PageBreakState
End If
End Sub

Display More

You can parse the required row into your other two codes by using Target.Row so there is no need to use ActRow = ActiveCell.Row.

I have done that and improved your "With.....End With" statements. Further improvements could well be possible but I would need to see your workbook to know for sure.

Code

Option Explicit
Dim Directorate As String, MA_Des As String
Dim DirectorateQty As Long, LastDirectorateRow As Long
Public Sub Show_Details_Top_Level(lRow As Long)
With Sheet1
Directorate = .Range("A" & lRow).Value2 'Get Directorate #
MA_Des = "*" & .Range("B" & lRow).Value2 & "*" 'Get Details #
.Range("F7:G7").Copy Sheet3.Range("HC4:HD4") 'Paste period for data
With Sheet3
LastDirectorateRow = .Range("B20999").End(xlUp).Row 'Get last Row of Directorate
DirectorateQty = .Range("HA999").End(xlUp).Row - 4 'Get The Number Of Directorate Lines
.Range("GG1:GL1") = .Range("HE4:HJ4").Value 'Paste Top Level Calcs#
.Range("GM1").Value = Sheet3.Range("HL4").Value 'Paste Top Level Calcs#
.Range("HA2:OV2,HA5:HL999").ClearContents 'Clear any previous data
.Range("HB2") = Directorate
.Range("II2") = MA_Des
.Range("ON2") = "Yes"
.Range("A1:GV" & LastDirectorateRow).AdvancedFilter , xlFilterCopy, .Range("HA1:OV2"), .Range("HA4:HL4"), True
If LastFiltRow < 5 Then GoTo NoDirectorate
With ActiveCell
.Value = "-"
.EntireRow.Offset(1).Resize(DirectorateQty + 1).Insert Shift:=xlDown 'Inserts # of Rows + 1 for Header
End With
End If
End With
With Range("D" & lRow + 1 & ":P" & lRow + 1)
.Value2 = .Range("AA2:AM2").Value2 'Add Nominal Header
.HorizontalAlignment = xlCenter 'Justify Center Nominal Header
End With
With Range("F" & lRow + 1 & ":O" & lRow + 1)
.HorizontalAlignment = xlCenter 'Justify Centre Nominal Header
.VerticalAlignment = xlBottom 'Justify Center Nominals Header
.WrapText = True ' Cells wrap
End With
With Range("C" & lRow + 2 & ":C" & lRow + 1 + DirectorateQty)
.Value = "+" 'Mark Line as Expand For Payment
.NumberFormat = "General" 'Format Invoice Numbers
End With
.Range("D" & lRow + 2 & ":P" & lRow + 1 + DirectorateQty).Value = Sheet3.Range("HA5:HL" & LastFiltRow).Value 'Add Details
.Range("D" & lRow + 1 & ":E" & lRow + 1 + DirectorateQty).Columns.AutoFit 'Column autofit
.Range("O" & lRow + 2 & ":O" & lRow + 1 + DirectorateQty).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)" ' Format Amounts
.Range("L" & lRow + 2 & ":L" & lRow + 1 + DirectorateQty).Style = "Percent" 'Format Amounts
With Range("P" & lRow + 2 & ":P" & lRow + 1 + DirectorateQty)
.Value = "N" 'Mark Line as Nominal
.HorizontalAlignment = xlCenter ' Category Column Justify Centre
.NumberFormat = "General" 'Format Category Column
End With
End With
Exit Sub
NoDirectorate:
MsgBox "There are no Details for this line"
End Sub
Public Sub Hide_Details_Top_Level(lRow As Long)
LastDirectorateRow = ActiveCell.Offset(1, -1).End(xlDown).Row - 1
With Sheet1
.Range(lRow + 1 & ":" & LastDirectorateRow).EntireRow.Delete
.Range("F" & lRow + 1 & ":O" & lRow + 9999).ColumnWidth = 11.22 'Column autofit
End With
ActiveCell.Value = "+"
Columns("D:E").Hidden = True 'Hide columns with Nominals and Description
End Sub

Display More

Posts by KjBox

USD 50 for creating a macro to copy sales data values from two excel sheets and paste in one Sheet with certain Conditions

USD 50 for creating a macro to copy sales data values from two excel sheets and paste in one Sheet with certain Conditions

USD 50 for creating a macro to copy sales data values from two excel sheets and paste in one Sheet with certain Conditions

USD 50 for creating a macro to copy sales data values from two excel sheets and paste in one Sheet with certain Conditions

USD 50 for creating a macro to copy sales data values from two excel sheets and paste in one Sheet with certain Conditions

VBA pivot table Insert Images- 20$

VBA pivot table Insert Images- 20$

VBA pivot table Insert Images- 20$

VBA pivot table Insert Images- 20$

VBA pivot table Insert Images- 20$

changing text to general using

VBA pivot table Insert Images- 20$

VBA pivot table Insert Images- 20$

VBA pivot table Insert Images- 20$

changing text to general using

changing text to general using

To improve code speed - drill down options on excel

To improve code speed - drill down options on excel

changing text to general using

To improve code speed - drill down options on excel