PDA

View Full Version : [SOLVED] Trying to code this VBA macro but it's beyond my knowledge



Jakers
07-16-2019, 03:59 AM
I've been given a set of instructions to manipulate weekly spreadsheets we receive from our tax fraud department and it would be really beneficial to set up a VBA macro as there are quite a few steps:


I've had a stab at it myself but it's well beyond me - I've given the steps below plus my attempts at each step if applicable

INPUT DATE
RUN DIALOGUE : ENTER DATE (IN DD/MM/YYYY FORMAT)

??


DATA MANIP

IF A CELL IN COLUMN K IS NOT BLANK, MOVE THE CELLS (OF THAT ROW) HIJK TO GHIJ


this is incorrect

IF(NOTBLANK(K),
Range("H:K").Select
Range("H:K").Cut Destination:=Range("G:J"), )


DELETE COLUMN A (UPRN)

Columns("A:A").Select
Selection.Delete Shift:=xlToLeft




DELETE COLUMNS NEWLY D & E & F (UNUSED ADDRESS FIELDS)

Columns("D:F").Select
Selection.Delete Shift:=xlToLeft


REPLACE "." WITH "/" IN NEW COLUMNS E AND F



Columns("E:F").Select
Selection.Replace What:=".", Replacement:="/", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False


TRIM ALL CELLS ... =TRIM






CHECK THE LAST 4 CHARACTERS OF ALL CELLS IN COLUMN E AND DELETE THAT RESPECTIVE ROW IF THE LAST FOUR CHARACTERS DO NOT EQUAL "2099" ... =RIGHT(F1, 4)






REMOVE LAST 5 CHARACTERS FROM ALL CELLS IN COLUMN F ... =LEFT(F1,






DELETE ANY ROWS IF THE DATE IN COLUMN F IS LESS THAN OR EQUAL TO THE DATE GIVEN IN STEP 1

??






DELETE COLUMNS E AND F


Columns("E:F").Select
Selection.Delete Shift:=xlToLeft


FORMATTING


EXPAND ALL

Cells.Select
Cells.EntireColumn.AutoFit




SELECT ALL CELLS THAT CONTAIN DATA AND CREATE BORDER



TYPE IN CELL READY TO PRINT



Columns("F:F").Select
Selection.ColumnWidth = 14
Range("F1").Select
ActiveCell.FormulaR1C1 = "READY TO PRINT!"

Paul_Hossler
07-16-2019, 06:39 AM
Doable, but a small representive sanitized sample workbook would make it easier

Attach it using the instructuins in my sig

Jakers
07-16-2019, 07:16 AM
Doable, but a small representive sanitized sample workbook would make it easier

Attach it using the instructuins in my sig

Thanks, attached a sample

Paul_Hossler
07-16-2019, 08:45 AM
Q: Do they give you the CSV file or an XLSX?

Q: Do you want to give them back an XLSX?

Q: Do you want a 'master' XLSM with the macro and just process the input data?



I'm assuming, Yes, Yes, and Yes.

The macro in WB#1 would open the CSV into another WB#2

Format WB#2

Save WB#2 as an XLSX

Jakers
07-17-2019, 01:37 AM
Q: Do they give you the CSV file or an XLSX?

Q: Do you want to give them back an XLSX?

Q: Do you want a 'master' XLSM with the macro and just process the input data?


The file comes to us as a .CSV, and ideally I'd like to open this in excel and run the macro and save as an XLSX

Paul_Hossler
07-17-2019, 09:29 AM
OK, look at this version

The 'dates' were a little tricky since they were not Excel-real dates, just strings that sort of looked like dates

I thought it was best to make them real dates, and format based on the Windows Regional Settings (US, UK, etc.) - screen shot in attachment Reformat.xlsm

I didn't know what Col A was to format it better

Anyway, I think I understood what you wanted to do, even if I changed the way you wanted to do it




Option Explicit

Const cModule As String = "Reformat File"

Sub ReformatFile()
Dim dtCutoff As Date

Dim csvPath As String, csvXLSX As String
Dim csvWorkbook As Workbook
Dim csvWorksheet As Worksheet

Dim i As Long, rowData As Long, colData As Long
Dim rData As Range


'get CSV filename, exit if canceled
csvPath = Application.GetOpenFilename("CSV File, *.csv")
If csvPath = "False" Then Exit Sub

'INPUT DATE - uses regional settings for date format
dtCutoff = Application.InputBox("Enter Cut Off Date, blank to Exit", "Cut Off Date", 0, , , , , 2)
If CLng(dtCutoff) = 0 Then Exit Sub

Application.ScreenUpdating = False


'make XLSX file name
i = InStrRev(csvPath, ".")
csvXLSX = Left(csvPath, i) & "xlsx"


'open CSV into new WB
Workbooks.Open Filename:=csvPath
Set csvWorkbook = ActiveWorkbook
Set csvWorksheet = ActiveSheet

Set rData = csvWorksheet.Cells(1, 1).CurrentRegion
With rData
.EntireColumn.AutoFit
'IF A CELL IN COLUMN K IS NOT BLANK, MOVE THE CELLS (OF THAT ROW) HIJK TO GHIJ
For rowData = 1 To .Rows.Count
If Len(.Cells(rowData, 11).Value) > 0 Then
For colData = 7 To 10
.Cells(rowData, colData).Value = .Cells(rowData, colData + 1).Value
Next colData
.Cells(rowData, 11).ClearContents
End If
Next rowData


'DELETE COLUMN A (UPRN)
.Columns(1).Delete

'DELETE COLUMNS NEWLY D & E & F (UNUSED ADDRESS FIELDS)
.Columns(6).Delete
.Columns(5).Delete
.Columns(4).Delete

'CHECK THE LAST 4 CHARACTERS OF ALL CELLS IN COLUMN E AND DELETE THAT RESPECTIVE ROW IF THE LAST FOUR CHARACTERS DO NOT EQUAL "2099"
For rowData = .Rows.Count To 1 Step -1 ' bottom's up
If Right(.Cells(rowData, 5).Value, 4) <> "2099" Then .Rows(rowData).EntireRow.Delete
Next rowData

'ADDED - make text into real dates, region settings independent
For rowData = 1 To .Rows.Count
'DD.MM.YYYY
'01.05.2019
.Cells(rowData, 4).Value = DateSerial(Right(.Cells(rowData, 4).Value, 4), Mid(.Cells(rowData, 4).Value, 4, 2), Left(.Cells(rowData, 4).Value, 2))
.Cells(rowData, 5).Value = DateSerial(Right(.Cells(rowData, 5).Value, 4), Mid(.Cells(rowData, 5).Value, 4, 2), Left(.Cells(rowData, 5).Value, 2))

'DD.MM.YYYY
'04.07.2019 14:18:50
.Cells(rowData, 6).Value = DateSerial(Mid(.Cells(rowData, 6).Value, 7, 4), Mid(.Cells(rowData, 6).Value, 4, 2), Left(.Cells(rowData, 6).Value, 2))
Next rowData

'DELETE ANY ROWS IF THE DATE IN COLUMN F IS LESS THAN OR EQUAL TO THE DATE GIVEN IN STEP 1
For rowData = .Rows.Count To 1 Step -1 ' bottom's up
If .Cells(rowData, 6).Value <= dtCutoff Then .Rows(rowData).EntireRow.Delete
Next rowData

'ADDED - should use regional settings
.Columns(6).NumberFormat = "m/d/yyyy"
.Columns(5).NumberFormat = "m/d/yyyy"
.Columns(4).NumberFormat = "m/d/yyyy"

End With

'delete xlsx if exists
Application.DisplayAlerts = False
On Error Resume Next
Kill csvXLSX
On Error GoTo 0
Application.DisplayAlerts = True
csvWorkbook.SaveAs Filename:=csvXLSX, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
csvWorkbook.Close

ThisWorkbook.Activate
Application.ScreenUpdating = True

Call MsgBox("File saved as " & vbCrLf & vbCrLf & csvXLSX, vbInformation + vbOKOnly, cModule)
End Sub

Jakers
07-19-2019, 01:59 AM
OK, look at this version

..



Wow Paul thank you so much ! This will save countless hours in the future for my team as well as our neighbouring authorities -

Just for formatting purposes, column B and C (post-macro) for some reason contain a lot of blank spaces after the data - how would I go about 'trimming' this unwanted space off the end?

I've played around with the cut-off date and using DD/MM/YYYY (I tried using 26/06/2019 (and it's still seemed to pull through prior dates)

Also once they have served their purpose I could delete columns E & F after the rest of the code, I assume I just use


.Columns(5).Delete
.Columns(6).Delete

From there I'll format it which I can add at the end of the code - my only query regarding this is - how would I go about adding borders around the text equal to the # of rows remaining on the spreadsheet? In the past I've just used a
Range("A1:D50").Select when the reports have always contained the same # of rows, but in this case, it can vary significantly

Paul_Hossler
07-19-2019, 07:12 AM
1. Just for formatting purposes, column B and C (post-macro) for some reason contain a lot of blank spaces after the data - how would I go about 'trimming' this unwanted space off the end?


2. I've played around with the cut-off date and using DD/MM/YYYY (I tried using 26/06/2019 (and it's still seemed to pull through prior dates)


3. Also once they have served their purpose I could delete columns E & F after the rest of the code, I assume I just use

4. From there I'll format it which I can add at the end of the code - my only query regarding this is - how would I go about adding borders around the text equal to the # of rows remaining on the spreadsheet?



1. See the .Trim

2. I put PC in UK date format mode so today = "19/07/2019" -- I don't see any Col F dates prior to 26/6/2019

"DELETE ANY ROWS IF THE DATE IN COLUMN F IS LESS THAN OR EQUAL TO THE DATE GIVEN IN STEP 1"


24643


3. Deleted E and F

4. Bordered

Jakers
07-19-2019, 08:54 AM
[/LEFT]

1. See the .Trim

2. I put PC in UK date format mode so today = "19/07/2019" -- I don't see any Col F dates prior to 26/6/2019

"DELETE ANY ROWS IF THE DATE IN COLUMN F IS LESS THAN OR EQUAL TO THE DATE GIVEN IN STEP 1"


24643


3. Deleted E and F

4. Bordered



Thank you Paul, seriously - you're an absolute godsend..!

Paul_Hossler
07-19-2019, 11:13 AM
<BLUSH>

Mark it SOLVED if you're done -- #3 in my sig