How to Apply Range of Formulas to Each Row in 100 Worksheets

[johnmeyer]

I have 100 worksheets from a doctor's office. Each row is data from a patient visit. Each cell in a row contains string data about the patient (name, blood pressure, etc.) as well as the date of the exam, diagnositcs, etc.

I want to create 100 new worksheets, but with some fairly basic manipulations performed on each cell. For instance, I want to separate the patient's name so that there is a cell with just the first name, and a cell with just the last name. I want to delete the word "DATE" which precedes the actual date in each cell. There will still be one row per patient visit, but there will me more columns (since I'm separating patient name into firstname/lastname).

I want each final worksheet to have string data, just like the source worksheet, and not have any formulas or references to the original worksheets.

All of this is very simple to do with formulas, and if I only had one worksheet, I'd insert various columns and create the formulas needed to do the work. I'd then "copy/paste special" to copy the results to the columns in the new worksheet, putting the results into columns in a different column order than in the original worksheet.

But, I have 100 worksheets.

I am using Excel 2003. I am very knowledgeable about how to use Excel, and reasonably proficient with VBA.

Question: Can anyone recommend a simple approach to solve this problem?

The solution I am going to try, if I don't get a better idea here, is to create a worksheet with a macro which prompts the user for the worksheet name of the first worksheet. I was then going to have the first row be the column names of the source worksheet, but in the order I want them to appear in the final worksheet. Below that, I was going to put the formulas for parsing each of these columns. And, below that, I was going to put the results of these formulas for the first row in the source worksheet.

The idea here is that I can modify the column order by simply putting different column letters in this template worksheet, and I can modify my parsing logic by changing the formulas.

However, this leads to my second and final question.

If what I outline is a sensible approach, is there a way in which VBA can use formulas contained in a cell in a spreadsheet, and apply them to a range?

This is a crude example of what I'm trying to do. The formulas are mostly bogus, just to indicate the idea, and I'm not using the file name or column letters to extract data. The key thing is that I want to apply the formulas in B5:H5 to the columns from the original spreadsheet, as shown by the column letters in row 3. I want to do this for every row in the source worksheet, and output the results to a new worksheet.

http://dl.dropbox.com/u/1561578/test.xls

If this is valid, my main stumbling block is knowing a way for VBA to use the formulas shown in B5:H5. I know I can hard-code those formulas in VBA, but I want the flexibility and interactivity of being able to modify them within the template and immediately see the results.


Thanks!!

 

[gregtx81]

This should be fairly easy to do.

But first, do you have 100 worksheets in a single workbook (i.e. 100 tabs in a single file) *or* 100 workbooks located in some directory? I ask b/c in your attachment you have "Worksheet Name: e:\patient data\Visit_001.xls", but this is a file path to a workbook and not a Worksheet name like "Sheet1".

 

[Michael M]

Hi John and Welcome to the Board
Have you tried storing the formulae as variables
See a couple of examples here.

http://answers.yahoo.com/question/index?qid=20110628181755AAaefuR

 

[johnmeyer]

This should be fairly easy to do.

But first, do you have 100 worksheets in a single workbook (i.e. 100 tabs in a single file) *or* 100 workbooks located in some directory? I ask b/c in your attachment you have "Worksheet Name: e:\patient data\Visit_001.xls", but this is a file path to a workbook and not a Worksheet name like "Sheet1".

Oops. I've been dealing with spreadsheets since Visicalc, and as a result I still think of spreadsheets, so I often make the mistake of using the word worksheet instead of workbook. Sorry.

Yes, I have 100 workbooks. These are 100 separate XLS files, each with only one worksheet. The "dummy" spreadsheet I linked to above has the file name hard-wired. If I get this running, I'll probably just put all 100 workbooks into a folder and have the macro open each one, apply the formulas and column rearrangement to each row, and then save the results in a new workbook with the same root name, plus an additional string to identify it as modified.

I hope you are right that it is easy to do. I have done some more research since I posted, and if I end up going down the path I outlined in my first post, it looks like the "evaluate" method may be what I need.

Hi John and Welcome to the Board
Have you tried storing the formulae as variables
See a couple of examples here.

http://answers.yahoo.com/question/index?qid=20110628181755AAaefuR

I could be wrong, but I think that what is posted in that link is the reverse of what I need to do. I know how to use formulas inside of VBA code, but I was hoping to avoid "hard-wiring" the macro with specific formulas because the doctor I'm working with has shown a desire to change things frequently. So, I want to make it easy for me to change the formulas and also change the order of the columns.

 

[johnmeyer]

OK, I have a very nice test worksheet that demonstrates clearly what I want to do. Here it is:

http://dl.dropbox.com/u/1561578/test Parsing Spreadsheet.xls

I want to iterate through every row in the source ("Data") Worksheet (i.e., do exactly what you do with the spinner control in this example) and then take the results of the formulas in B6:H6 for each of these rows and put the results of those formulas (the equivalent of "Paste Special") into a new Workbook.

Iterating through the rows is trivial; the part that has me stumped is how to easily and efficiently use VBA to take the results of cells B6:H6 and create a new workbook from those results. Is it as simple as stuffing a new value into the row cell (B2 in this example) and then having VBA get the information from each cell in the B6:H6 range, or is there a more efficient way to achieve this?

I know how to hard-wire formulas into VBA, but I don't want to do that, because as you can see from this example, this approach lets me interactively change and "tune" the formulas in B6:H6 to get exactly what I want, and I can use the spinner to quickly check the results for the rows in the source Worksheet. Also, I want to give the end-user of this the ability to change formulas, and the end user has not idea now to use macros.

 

[gregtx81]

Hi John,

Here's code that will "loop the spinner".

Are you still looking to loop the workbooks? If so, is the data formatted as it is on the 'Data' tab of the workbook you most recently linked to-- i.e. starting on the row 1, with no headers, and in columns A-I?

Sub loopValues()
    
    Application.ScreenUpdating = False
    
    'creates new workbook
    Dim newWB As Workbook
    Set newWB = Workbooks.Add
    
    'find last row of data on Sheet 'Data'
    With Workbooks("test parsing spreadsheet.xls").Worksheets("Data")
        lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
    End With
    
    With Workbooks("test parsing spreadsheet.xls").Worksheets("Template")
        For i = 1 To lastrow  'the values you want to loop
            .Range("B2").Value = i
            newWB.Sheets(1).Range("A" & i).Resize(1, 7).Value = .Range("B6:H6").Value
        Next i
    End With
    Application.ScreenUpdating = True
End Sub

 

[johnmeyer]

Here's code that will "loop the spinner".

Well, that appears to be just about perfect! That solves my main problem, and I should be able to finish the project today. Thank you, thank you.

Are you still looking to loop the workbooks? If so, is the data formatted as it is on the 'Data' tab of the workbook you most recently linked to-- i.e. starting on the row 1, with no headers, and in columns A-I?

Yes, it is still my plan to do that, and yes, the data is formatted precisely as it is in the DATA worksheet.

I have another version of the spreadsheet that I uploaded, but this one uses the path\filename of the workbook (located in B1), along with the following formula in place of the ones you see in row 5:

=INDIRECT("'"&$B$1&"'!"&B7&TEXT($B$5,0))

This lets me retrieve information directly from the workbook rather than from another worksheet in the existing workbook, although I think I must first open the workbook and later close it.

I was just going to use this in a VBA loop similar to the one shown below. This code is from the Word VBA macros I wrote which I then used to create all these Excel files. This code opens all the DOC or DOCX files in a specified folder, and then executes the "APatient" sub for each file found. I haven't implemented the Excel version of this yet, so if you have a better idea of how to proceed, let me know. You clearly are way ahead of me on this stuff.

Application.FileDialog(msoFileDialogFolderPicker).Show
vDirectory = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)

vFile = Dir(vDirectory & "\" & "*.doc*")

Do While vFile <> ""

    Documents.Open filename:=vDirectory & "\" & vFile
    APatient

    ActiveDocument.Close savechanges:=False
    vFile = Dir()
Loop
Finish:
    Exit Sub
CatchError:
    MsgBox (Err.Description & Chr(13) & Chr(13) & "  (No folder/directory selected, or temp.doc not open.)")
    GoTo Finish
End Sub

 

[gregtx81]

Using an indirect formula to get the file name is certainly feasible (perhaps even preferable b/c it would consist of much less copy/pasting). Anyhow, below I strung together the two procedures contained in this thread.

If the whetherAppend variable is set to false, the code will, looping over the directory, open a file, copy the contents to the cleared DATA worksheet, run the spinner loop, and close each opened file.

If the whetherAppend variable is set to true, the content of all the files are appended to one another within the DATA sheet, and the spinner loop is run only once at the conclusion of the procedure.

Sub fileloop()
    Application.FileDialog(msoFileDialogFolderPicker).Show
    vDirectory = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
    
    Dim whetherAppend As Boolean
    whetherAppend = False
    
    'creates new workbook
    Dim newWB As Workbook
    Set newWB = Workbooks.Add

    
    Workbooks("test parsing spreadsheet.xls").Worksheets("Data").UsedRange.ClearContents
    vFile = Dir(vDirectory & "\" & "*.xls*")

    Do While vFile <> ""

        Set wbopened = Workbooks.Open(Filename:=vDirectory & "\" & vFile)
        
        
        

    If whetherAppend Then
        With Workbooks("test parsing spreadsheet.xls").Worksheets("Data")
            lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
            If lastrow <> 1 Then lastrow = lastrow + 1
            wbopened.Sheets(1).UsedRange.Copy (.Range("A" & lastrow))
        End With
    Else
        With Workbooks("test parsing spreadsheet.xls").Worksheets("Data")
            .UsedRange.ClearContents
            wbopened.Sheets(1).UsedRange.Copy (.Range("A1"))
        End With
    End If
    
    If whetherAppend = False Then Call loopValues(newWB)

    wbopened.Close savechanges:=False
    vFile = Dir()
    
Loop
    If whetherAppend = True Then Call loopValues(newWB)
Finish:
    Exit Sub
CatchError:
    MsgBox (Err.Description & Chr(13) & Chr(13) & "  (No folder/directory selected, or temp.doc not open.)")
    GoTo Finish
End Sub

Sub loopValues(ByVal newWB As Workbook)
    
    Application.ScreenUpdating = False
    
    
    'find last row of data on Sheet 'Data'
    With Workbooks("test parsing spreadsheet.xls").Worksheets("Data")
        lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
    End With
    
    With Workbooks("test parsing spreadsheet.xls").Worksheets("Template")
        lastRowNewWB = newWB.Sheets(1).Range("A" & newWB.Sheets(1).Rows.Count).End(xlUp).Row
        If lastRowNewWB = 1 Then lastRowNewWB = lastRowNewWB - 1
        For i = 1 To lastrow  'the values you want to loop
            .Range("B2").Value = i
            newWB.Sheets(1).Range("A" & i + lastRowNewWB).Resize(1, 7).Value = .Range("B6:H6").Value
        Next i
    End With
    Application.ScreenUpdating = True
End Sub

 

[johnmeyer]

Using an indirect formula to get the file name is certainly feasible (perhaps even preferable b/c it would consist of much less copy/pasting). Anyhow, below I strung together the two procedures contained in this thread.

Sorry for taking a little while to get back to you. I was working on developing "the ultimate" parsing logic to take names that are contained in a single cell and parsing them into first and last names, taking into account both suffixes (Jr., III, pHD), punctuation (periods and commas), and compound last names (De Berg, von Dyke). I now have that working.

With your code to let me open external workbooks rather than having to copy the data to the DATA worksheet, I think I can finish this project off in the next hour or so.

Again, thank you very, very much.

 

[johnmeyer]

I thought it might be worthwhile to show the final results. As part of this project, I also created a very nice way to extract first & last names from a cell that contains the whole name in one cell. I did this using a table that has all the normal suffixes (Jr., Sr., III, IV, MD, etc.); and the compound name prefixes (von, van, der, di, etc.) for names like "van Dyke"; and also all the exceptions to proper case so that III doesn't get changed to Iii.

Here's the main sheet:

Excel Workbook
	A	B	C	D	E	F	G
1	Workbook name:	E:\Chuck Medical Records\pt records 2009.xls
2	Row	1
3
4	Source Columns	I	I	E	A	B	C
5	Source Data (from workbook)	Name John van Jones, III	Name John van Jones, III	Date 07/13/09	feels well. No physical complaints. No chest pain sob. RX: Lipitor 20mg/d synthroid .05mg/d	PE 138/70P70 HEENT thyroid nl LUNGS:clear C: no S3 S4 murmur ABD: no masses tenderness	1.hypercholesterolemia 2.hypothyroidism
6	Formulas (output)	John	van Jones, III	07/13/09	feels well. No physical complaints. No chest pain sob. RX: Lipitor 20mg/d synthroid .05mg/d	138/70P70 HEENT thyroid nl LUNGS:clear C: no S3 S4 murmur ABD: no masses tenderness	1.hypercholesterolemia 2.hypothyroidism
7
8	Scratchpad
9	Full Name	John van Jones, III
10	Number of compound words	1
11	Number of Suffixes	1
12	Number of spaces	3
13	Second Name Start Position	5
Template

Excel 2002

Cell Formulas
Range	Formula
B5	=INDIRECT("'"&$B$1&"'!"&B4&TEXT($B$2,0))
B6	=CorrectCase(TRIM(LEFT(B9,B13)),words)
B9	=RIGHT(B5,LEN(B5)-FIND(" ",B5,1))
B10	=SUMPRODUCT(--ISNUMBER(FIND(" "&TRIM(compound)&" "," "&NoPunc&" ")))
B11	=SUMPRODUCT(--ISNUMBER(FIND(" "&TRIM(suffix)&" "," "&NoPunc&" ")))
B12	=Spaces
B13	=SEARCH(CHAR(127),SUBSTITUTE(TRIM(B9)," ",CHAR(127),(B12-B11-B10)))
C5	=INDIRECT("'"&$B$1&"'!"&C4&TEXT($B$2,0))
C6	=CorrectCase(TRIM(RIGHT(B9,LEN(B9)-B13)),words)
D5	=INDIRECT("'"&$B$1&"'!"&D4&TEXT($B$2,0))
D6	=RIGHT(D5,LEN(D5)-FIND(" ",D5,1))
E5	=INDIRECT("'"&$B$1&"'!"&E4&TEXT($B$2,0))
E6	=TRIM(E5)
F5	=INDIRECT("'"&$B$1&"'!"&F4&TEXT($B$2,0))
F6	=RIGHT(TRIM(F5),LEN(TRIM(F5))-FIND(" ",TRIM(F5),1))
G5	=INDIRECT("'"&$B$1&"'!"&G4&TEXT($B$2,0))
G6	=TRIM(G5)

Excel Workbook
Name	Refers To
compound	=Lists!$C$3:$C$20
NoPunc	=UPPER(SUBSTITUTE(SUBSTITUTE(Template!A$9,".",""),",",""))
Spaces	=LEN(TRIM(Template!A$9))-LEN(SUBSTITUTE(TRIM(Template!A$9)," ",""))
suffix	=Lists!$B$3:$B$17
words	=Lists!$A$3:$A$31
Workbook Defined Names

And here are the various user defined functions and procedures. Note in the defined names above that I made extensive use of defined name formulas (e.g., NoPunc).

Function CorrectCase(ByVal inputString As String, ByVal caseListRange As Range) As String
    Dim arrWords As Variant
    Dim i As Long, Pointer As Long
    On Error GoTo Halt
    Pointer = 1
    CorrectCase = inputString
    arrWords = WordsOf(inputString)
    
    For i = 0 To UBound(arrWords)
        Pointer = InStr(Pointer, inputString, arrWords(i))
        Mid(CorrectCase, Pointer) = CorrectCaseOneWord(CStr(arrWords(i)), caseListRange)
    Next i
    
Halt:
    On Error GoTo 0
End Function
Function WordsOf(inputString As String) As Variant
    Dim Delimiters As Variant, aDelimiter As Variant
    Dim arrResult As Variant
    
    Delimiters = Array(" ", ",", ".", ";", ":", Chr(34), vbCr, vbLf): Rem add to as needed
    
    For Each aDelimiter In Delimiters
        inputString = Application.Substitute(inputString, aDelimiter, Delimiters(0))
    Next aDelimiter
    
    arrResult = Split(inputString, CStr(Delimiters(0)))
    WordsOf = arrResult
End Function

Function CorrectCaseOneWord(inWord As String, caseListRange As Range) As String
    With caseListRange
        If IsError(Application.Match(inWord, .Cells, 0)) Then
            CorrectCaseOneWord = Application.Proper(inWord)
        Else
            CorrectCaseOneWord = Application.Lookup(inWord, .Cells)
        End If
    End With
End Function


Sub Spinner4_Change()

End Sub
Sub OpenWorkbookFile()
    With Application.FileDialog(msoFileDialogFilePicker)
    
      ' Clear out the current filters, and add our own.
      .Filters.Clear
      .Filters.Add "Excel Spreadsheets", "*.XLS"
      .Filters.Add "Text Files", "*.TXT"

    If .Show = True Then
        vFile = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(1)
    Else
        Exit Sub
    End If
    End With
    
    'Open workbook that contains the data
    Set wbopened = Workbooks.Open(Filename:=vFile)
    
    With Workbooks(ThisWorkbook.Name).Worksheets("Template")
        .Range("B1").Value = vFile
    End With
    Workbooks(ThisWorkbook.Name).Worksheets("Template").Activate
End Sub



Sub ExtractData()
    Application.ScreenUpdating = False
    
    'creates new workbook
    Dim newWB As Workbook
    
    With Workbooks(ThisWorkbook.Name).Worksheets("Template")
        Set wbopened = Workbooks.Open(Filename:=Range("B1"))
    End With
    
    With wbopened.Sheets(1)
        lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
    End With
    
    Set newWB = Workbooks.Add
    
    With Workbooks(ThisWorkbook.Name).Worksheets("Template")
        For i = 1 To lastrow  'the values you want to loop
            .Range("B2").Value = i
            newWB.Sheets(1).Range("A" & i).Resize(1, 7).Value = .Range("parsed").Value
        Next i
    .Range("B2").Value = 1
    End With

    wbopened.Close savechanges:=False
    Application.ScreenUpdating = True
    
End Sub