Code To Open Files Within Folder Make Changes And Close

[Dazzawm]

I need a code that will open dozens of files within a folder in my desktop and if what is found in column A in the active sheet in column AG in each file then it needs to be changed to what is in column B as below. Thanks

Excel 2010

	A	B
1	Column AG	Changes To
2	Centre	Centre
3	Centre-LH	LH Centre
4	Centre-RH	RH Centre
5	FR	FR
6	FR Inner-LH	FR LH Inner
7	FR Inner-RH	FR RH Inner
8	FR Lower-LH	FR LH Lower
9	FR Lower-RH	FR RH Lower
10	FR Outer-LH	FR LH Outer
11	FR Outer-RH	FR RH Outer
12	FR Upper	FR Upper
13	FR Upper-LH	FR LH Upper
14	FR Upper-RH	FR RH Upper
15	FR-DS	FR DS
16	FR-Inner	FR Inner
17	FR-LH	FR LH
18	FR-Outer	FR Outer
19	FR-PS	FR PS
20	FR-RH	FR RH
21	Inner	Inner
22	Inner-LH	LH Inner
23	Inner-RH	RH Inner
24	LH	LH
25	Outer	Outer
26	Outer-LH	LH Outer
27	Outer-RH	RH Outer
28	RH	RH
29	RR	RR
30	RR Inner-LH	RR LH Inner
31	RR Inner-RH	RR RH Inner
32	RR LH+RH	RR LH+RH
33	RR-Inner	RR Inner
34	RR-LH	RR LH
35	RR-Outer	RR Outer
36	RR-RH	RR RH

<colgroup><col style="width: 25pxpx"><col><col></colgroup><thead>
</thead><tbody>
</tbody>

Sheet1​

So looking at row 3 if Centre-LH is found in column AG of any of the files then it needs to change it to LH Centre, save and close each file and so on...

 

[Dazzawm]

Thanks Tony the first part seems to work great. The second part is not quite what I need. If any word(s) are found in column AG that are not in the list in column A then I would like to know the file it is in and the word(s) starting in column C.

So if the word 'thanks' is found in AG in the file named 'Sample' and it is not in the list in column A (which it is not in this case) then the file name of Sample will be in C1 and the word 'thanks' will be underneath and so on with any other words found in other files. We are almost there and if this could be done it would be great. Thanks.

 

[Snakehips]

Try this....

Sub CheckSheets()


    Dim fDialog         As Office.FileDialog
    Dim varFile         As Variant
    Dim wb              As Workbook
    Dim ws              As Worksheet
    Dim lookupRange     As Range
    Dim newRange        As Range
    Dim thisCell        As Range
    Dim r               As Long
    Dim nmr              As Long
    Dim lstCol          As Long
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set lookupRange = ThisWorkbook.Sheets("LookUp").Range("A1:A36")     '*****Set as you see fit
    Set newRange = ThisWorkbook.Sheets("LookUp").Range("B1:B36")         '*****Set as you see fit
    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
    
    With fDialog
        .AllowMultiSelect = True
        .Title = "Import Files"
        .Filters.Clear
        .Filters.Add "Excel Documents", "*.xlsx"
        .Filters.Add "Excel Macro Documents", "*.xlsm"
        .Filters.Add "All Files", "*.*"
    End With
    
    If fDialog.Show Then
    'Check for cancel
        
        For Each varFile In fDialog.SelectedItems
        
            lstCol = Cells(1, Columns.Count).End(xlToLeft).Column + 1
             nmr = 2  'report no match row
    
            Set wb = Workbooks.Open(varFile)
            Set ws = wb.Sheets(1) '*****  uses first sheet or if all the same names then ws.Sheets("yoursheet")
            Cells(1, lstCol) = wb.Name
            For Each thisCell In ws.Range("AG2:AG" & ws.Range("C" & ws.Rows.Count).End(xlUp).Row)   '*****Set as you see fit  Column C
            r = 0
                On Error Resume Next
                r = Application.WorksheetFunction.Match(thisCell.Value, lookupRange, 0)
                On Error GoTo 0
                If r > 0 Then
                     thisCell.Value = Application.WorksheetFunction.Index(newRange, r)
                 Else
                     '**** Mark the word as having been found in AG but not in change list
                     If Not thisCell = "" Then Application.WorksheetFunction.Index(lookupRange.Offset(0, lstCol - 1), nmr, 1) = thisCell
                     nmr = nmr + 1
                End If
        
            Next thisCell
            
            Application.Calculate
            wb.Close True
        
        Next varFile
    
    End If


    Application.Calculation = xlCalculationSemiautomatic
    Application.ScreenUpdating = True


End Sub

 

[Dazzawm]

Thanks Tony almost perfect! When it finds a word in a file not listed in column A it lists it every time it is not in the file so in this example if the word 'thanks' is listed 100 times in the Sample file it lists it 100 times in column C. Could it be done so it is listed just once and the same with the next word that may be found in that file. If its too tricky then no problem.

 

[Snakehips]

Dazza,

This is my final fling before bed....

Sub CheckSheets()


    Dim fDialog         As Office.FileDialog
    Dim varFile         As Variant
    Dim wb              As Workbook
    Dim ws              As Worksheet
    Dim lookupRange     As Range
    Dim newRange        As Range
    Dim thisCell        As Range
    Dim r               As Long
    Dim x               As Long
    Dim nmr             As Long
    Dim lstCol          As Long
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set lookupRange = ThisWorkbook.Sheets("LookUp").Range("A1:A36")     '*****Set as you see fit
    Set newRange = ThisWorkbook.Sheets("LookUp").Range("B1:B36")         '*****Set as you see fit
    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
    
    With fDialog
        .AllowMultiSelect = True
        .Title = "Import Files"
        .Filters.Clear
        .Filters.Add "Excel Documents", "*.xlsx"
        .Filters.Add "Excel Macro Documents", "*.xlsm"
        .Filters.Add "All Files", "*.*"
    End With
    
    If fDialog.Show Then
    'Check for cancel
        
        For Each varFile In fDialog.SelectedItems
        
            lstCol = Cells(1, Columns.Count).End(xlToLeft).Column + 1
             nmr = 2  'report no match row
    
            Set wb = Workbooks.Open(varFile)
            Set ws = wb.Sheets(1) '*****  uses first sheet or if all the same names then ws.Sheets("yoursheet")
            Cells(1, lstCol) = wb.Name
            For Each thisCell In ws.Range("AG2:AG" & ws.Range("C" & ws.Rows.Count).End(xlUp).Row)   '*****Set as you see fit  Column C
            r = 0
                On Error Resume Next
                r = Application.WorksheetFunction.Match(thisCell.Value, lookupRange, 0)
                On Error GoTo 0
                If r > 0 Then
                     thisCell.Value = Application.WorksheetFunction.Index(newRange, r)
                 Else
                     '**** Mark the word as having been found in AG but not in change list
                     If Not thisCell = "" Then
                            x = 0
                            On Error Resume Next
                            x = Application.WorksheetFunction.Match(thisCell.Value, lookupRange.Offset(0, lstCol - 1), 0)
                            On Error GoTo 0
                            If x = 0 Then
                                Application.WorksheetFunction.Index(lookupRange.Offset(0, lstCol - 1), nmr, 1) = thisCell
                                nmr = nmr + 1
                            End If
                     End If
                End If
        
            Next thisCell
            
            Application.Calculate
            wb.Close True
        
        Next varFile
    
    End If


    Application.Calculation = xlCalculationSemiautomatic
    Application.ScreenUpdating = True


End Sub

ZZZZZZ..... ZZZZZZZZZ....ZZZZZZZZ

 

[Dazzawm]

I appreciate all your hard work especially this late. I will try it in the morning.

 

[Dazzawm]

Hi Tony, tried this morning and the second part doesnt work at all. It lists a couple of the words that is in one of the files that is not in column A but it lists them over the data in column B and doesnt give the name of the file in row 1. Also it hasnt given some words from other files. Dont worry the code in post 12 seems to be ok i will just do a manual 'remove duplicates' on each column at the end. I thank you for all your time and hard work.

Thank you also Adam and next time your in Soton drop me a PM and we will meet for a bevvy.

 

[Snakehips]

Dazza,

Sorry for late response but have been out all day.

Previous code tested ok here on limited data but I can now see how it might be lacking if you have many un-matched words.
Re the printing in column B. The code requires that there be a header of some sort in B1 so that the printing starts at C1. Could be anything, XXXXXXX, just as long as it is not blank.

Excel 2007
	B	C
1	!!!Must Not be BLANK"!!	Dazza.xlsx
2	Centre	frtyu
3	LH Centre	xxxxx
4	RH Centre	RR Outer
5	FR	RR RH
6	FR LH Inner	zzz
7	FR RH Inner	aa1
8	FR LH Lower	aa2
9	FR RH Lower	aa3
Lookup

If it's not too late, I feel the below code should now be aok. I would be interested to know if it works for real at your end.

Sub CheckSheets()


    Dim fDialog         As Office.FileDialog
    Dim varFile         As Variant
    Dim wb              As Workbook
    Dim ws              As Worksheet
    Dim lookupRange     As Range
    Dim newRange        As Range
    Dim thisCell        As Range
    Dim r               As Long
    Dim x               As Long
    Dim nmr             As Long
    Dim lstCol          As Long
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set lookupRange = ThisWorkbook.Sheets("LookUp").Range("A1:A36")     '*****Set as you see fit
    Set newRange = ThisWorkbook.Sheets("LookUp").Range("B1:B36")         '*****Set as you see fit
    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
    
    With fDialog
        .AllowMultiSelect = True
        .Title = "Import Files"
        .Filters.Clear
        .Filters.Add "Excel Documents", "*.xlsx"
        .Filters.Add "Excel Macro Documents", "*.xlsm"
        .Filters.Add "All Files", "*.*"
    End With
    
    If fDialog.Show Then
    'Check for cancel
        
        For Each varFile In fDialog.SelectedItems
        
            lstCol = Cells(1, Columns.Count).End(xlToLeft).Column + 1
             nmr = 2  'report no match row
    
            Set wb = Workbooks.Open(varFile)
            Set ws = wb.Sheets(1) '*****  uses first sheet or if all the same names then ws.Sheets("yoursheet")
            Cells(1, lstCol) = wb.Name
            For Each thisCell In ws.Range("AG2:AG" & ws.Range("C" & ws.Rows.Count).End(xlUp).Row)   '*****Set as you see fit  Column C
            r = 0
                On Error Resume Next
                r = Application.WorksheetFunction.Match(thisCell.Value, lookupRange, 0)
                On Error GoTo 0
                If r > 0 Then
                     thisCell.Value = Application.WorksheetFunction.Index(newRange, r)
                 Else
                     '**** Mark the word as having been found in AG but not in change list
                     If Not thisCell = "" Then
                            x = 0
                            On Error Resume Next
                            x = Application.WorksheetFunction.Match(thisCell.Value, ThisWorkbook.Sheets("Lookup").Range(Cells(2, lstCol), Cells(nmr + 1, lstCol)), 0)
                            On Error GoTo 0
                            If x = 0 Then
                               ThisWorkbook.Sheets("Lookup").Cells(nmr, lstCol) = thisCell
                                nmr = nmr + 1
                            End If
                     End If
                End If
        
            Next thisCell
            
            Application.Calculate
            wb.Close True
        
        Next varFile
    
    End If


    Application.Calculation = xlCalculationSemiautomatic
    Application.ScreenUpdating = True


End Sub

 

[Dazzawm]

I am sorry Tony but it is still not working. The first part of the code is fine, sorted. But the second is the stumbling block. Firstly it is not putting the name of the file in row 1 where data is found that is not in the list. Secondly all the words of the data found from each file is being put in column C and not one of each so it is stretching down 50000 rows instead of about 10!

I am trying it using 3 files. The first file has all the data that is coulmn A so it changes it to what is in B as it should. The next 2 files have none of the data that is in A so all the data that is in file 2 should be copied to column C (file 2 in C1) but only each word once, so in essence a 'remove all duplicates' needs performing on that column. And the same in column D with the third file with file 3 as a header in D1. I know it is being a headache for you but luckily enough I won't be using for 'real' until tomorrow, so that it is why I wanted to get it sorted the last couple of days. If you can get to the bottom of it then great, but if not like I say I could use your code in #12.

Thanks.

 

[Snakehips]

Dazza,

It works absolutely fine for me at this end.
Column C post #17 shows various non matches reported once whereas there were 50 or so of each in the test AG column of file being converted.

Without testing it on your data I am at a loss as what more I can do.

 

[Dazzawm]

This is bizarre! I have created some small files to upload for you to look at and upon checking them the code runs as expected. But when I try it on my very large files (which are exactly laid out the same) the code fails? The files I am trying to use the code on has macros embedded in them but that shouldn't make a difference should it?