VBA is executing across 2 files

[cforrester1981]

I am at wits end. I have no idea what is going on here.

I have posted previously that I am a VBA noob and using macros to learn VBA but the bit of programming experience that I have clearly isn't helping me find the problem with my code.

Some context: My client uses our software to pull a variety of different reports. However, the limitation of the software means that the one piece of data they require is tied up in a text string within a cell. I want to create a macro-enabled Excel file with different buttons that will extract the data from each of the different report formats. I have managed (with the help of this forum) to work out how extract my data. However, before I extract the data, I need to create a column to put the data in.

Below is my code. The problem I am having is that after the unmerging of the cells (the report is generated with merged cells), I need to copy the contents of cell A1 in the target file to the cell B1 in the target file. The code is correctly selecting and copying cell A1. However, when it has to select cell B2, it somehow switches back to the macro file and then the paste instruction pastes the contents to that file instead. I've marked where the problem lies. I've also included some screenshots so that you can see the outcome

Sub OpenFile()
    Dim StrFile As String
    Dim wb As Workbook
    
    StrFile = Application.GetOpenFilename(fileFilter:="Excel files (*.xls*), *.xls*", Title:="Choose an Excel file to open")
    Set wb = Workbooks.Open(StrFile)
        DoWork wb
        wb.Close SaveChanges:=True
End Sub
Sub DoWork(wb As Workbook)
    
    With wb
'   Unmerge all cells
    Cells.Select
    Selection.UnMerge
'   Copy Referring Doctor label to B1
    Range("A1").Select
    Selection.Copy
    Range("B1").Select '<-- PROBLEM LIES HERE!!!!
    ActiveSheet.Paste ' <-- AND HERE!!!!
'   Delete column A
    Columns("A:A").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
'   Copy column B to column I (so that the cell formatting is able to be duplicated)
    Columns("B:B").Select
    Selection.Copy
    Columns("I:I").Select
    Selection.Insert Shift:=xlToRight
    Application.CutCopyMode = False
'   Clear contents of column I and add new heading
    Selection.ClearContents
    Range("I1").Select
    ActiveCell.FormulaR1C1 = "Practice Number"
'   Move column I and insert it between column A & B
    Selection.Cut
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight
End Sub

Before starting the macro

The unmerge, select and copy work correctly

It's pasted the copied text in the wrong file.

I have even tried to use wb = ActiveWorkBook before the select and paste. That didn't work either.

If I get this last bit working, the rest of my code works and I can carry on.

Thanks again for all your help. This noob feels like a complete dunce. ?

 

[cforrester1981]

Sorry, I am pasting to B1, not B2 (typo and I can't find anywhere to edit my orignal post)

 

[Peter_SSs]

Where do you have this code in the 'macro file'?
- Standard Module
- Worksheet module
- ThisWorkbook module

Have you posted the whole code? Asking because it has "With wb" but it does not have a corresponding "End With". Therefore the posted code will not actually execute the DoWork procedure at all.

Any chance that you could give us a small set of dummy data (that is no sensitive data) to test with? You could use XL2BB or perhaps upload to DropBox, OneDrive etc and provide a shared link here?

 

[cforrester1981]

Sure, no problem. Below is a link to the 2 files.

MrExcel - Google Drive

drive.google.com

File 1 (Ref Doctor Report Converter.xlsm) has the macro I want to run. You will see there is some code I commented out. That code is working. I just commented it out so that I could debug without running the extraction of the practice numbers.

File 2 (Turnover report.xls) is a data sample. Basically, I want to extract the doctors' practice numbers (the 7 digit numbers following (Pr: )and have them appear in a column next to the doctor's name. The client wants these practice numbers separate and my company's software is unable to do that in these reports without extensive development (which we will do but this is a temprary solution). After playing around for 2 days, I found that the only way to get the column to appear correctly is to unmerge all the cells, copy a column to column I, clear the contents, add a heading and cut and insert the column back. This way there is the correct cell formatting. Simply inserting the column leaves the cells unformatted. I deleted column A as it was not needed.

Note: The reports are generated in .xls format, NOT.xlsx.

 

[mumps]

Try this macro. You no longer need the "DoWork" macro.

Sub OpenFile()
    Application.ScreenUpdating = False
    Dim StrFile As String, wb As Workbook, x As Long, LastRow As Long
    StrFile = Application.GetOpenFilename(fileFilter:="Excel files (*.xls*), *.xls*", Title:="Choose an Excel file to open")
    Set wb = Workbooks.Open(StrFile)
    With wb.Sheets("July 2020 Doctors revenue")
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .Cells.UnMerge
        .Range("A1").Copy .Range("B1")
        .Columns("A").Delete
        .Columns("B").Copy
        .Columns("I").Insert Shift:=xlToRight
        .Columns("I").ClearContents
        .Range("I1") = "Practice Number"
        .Columns("I").Cut
        .Columns("B").Insert Shift:=xlToRight
        .Range("B3:B" & LastRow).NumberFormat = "0000000"
        For x = 3 To LastRow Step 3
            .Range("B" & x) = Mid(.Range("A" & x), WorksheetFunction.Find("Pr:", .Range("A" & x)) + 4, 7)
        Next x
    End With
    wb.Close SaveChanges:=True
    Application.ScreenUpdating = True
End Sub

 

[Peter_SSs]

My suggestion
Move your procedures out of the ThisWorkbook module and put them in a standard module (Insert-> Module) on the menus.
I have left your OpenFile procedure exactly how it was and changed the DoWork procedure to this

Sub DoWork(wb As Workbook)
  Application.ScreenUpdating = False
  With wb.Sheets(1)
'    Unmerge all cells
    .Cells.UnMerge
'    Copy Referring Doctor label to B1
    .Range("B1").Value = .Range("A1").Value
'    Delete column A
    .Columns("A").Delete
'    Insert new column (copy format from right)
    .Columns("B").Insert CopyOrigin:=xlFormatFromRightOrBelow
'    Insert Heading
    .Range("B1").Value = "Practice Number"
'    Populate all practice numbers at once
    With .Range("B3:B" & .Range("A" & .Rows.Count).End(xlUp).Row)
      .FormulaR1C1 = "=IF(R[1]C[-1]="""",LEFT(RIGHT(RC[-1],8),7),"""")"
      .NumberFormat = "@"
      .Value = .Value
    End With
  End With
  Application.ScreenUpdating = True
End Sub

 

[cforrester1981]

Thanks guys. These suggestions are all great.

@mumps I like how simplified your code is. I've actually implemented it and it's working well.

@Peter_SSs Your code has shown me how to use dynamic cell referencing in VBA which I was also having problems with. However, I see your code did not apply to every third line and your number format was not what I wanted. I could just have added a FOR loop to your code and set the number format to "0000000" (like in @mumps code). Your use of the LEFT and RIGHT operators is also a different way of approaching it. All practice numbers are 7 digits and at the end so this could work as well. I have to say that although @mumps code was implemented, I like having separate sub-routines. It's compartmentalises the work done and allows you to work on a small section of code without messing with other stuff that is already working.

Once again, thank you all for the assistance. It is greatly appreciated.

 

[cforrester1981]

Sorry guys, Can I ask one last favour....

How do I save this file as an XLSX file at the end of the extraction process without a prompt?

 

[Peter_SSs]

How do I save this file as an XLSX file at the end of the extraction process without a prompt?

With the same name (apart from the xlsx) and in the same location?

 

[cforrester1981]

With the same name (apart from the xlsx) and in the same location?

Correct