Modify RDB code with find and offset

J

John Yab

Could someone help me to modify the appended code from Ron de Bruins web
site, please? The values I really want to obtain are shown in the code
(namely in D1,O20,O38) but rather than hard coding D1,O20,O38 I would like to
use “find†and then “offset†to obtain them and use the code of “find†and
“offset†to replace: “Set Rng = Range("D1,O20,O38")â€. To restate this:
I would like to “find†the text: “Lot*†(located in B1) then offset 2
columns to the right to arrive at D1
I would like to “find†the text: “Grand*†(located in N20) then offset 1
column to the right to arrive at O20
I would like to “find†the text: “Grand*†(located in N38) then offset 1
column to the right to arrive at O38
This would allow for someone typing one of the key words of “Lot†or “Grandâ€
in a different cell but still return the value that is referenced by these
labels. Or if there is a better way than using “find†and “offset†then that
would be good too. The texts are actually: “Lot # :†and “Grand Average:†but
I was thinking to search with a wild card, * as sometimes the text is typed
slightly different, eg: Avg instead of Average. I am using Excel 2007 with
Vista. This is my first newsgroup post. Thanks, John Yab.

Sub TagTeam_QA()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "QA" '<---- matches the name of the sheet to be searched
Set Rng = Range("D1,O20,O38") '<---- matches the specific cells to
collect

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files,
*.xl*", MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing

'Change ScreenUpdating and calculation to increase speed of macro
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 3
RwNum = 2

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'",
"''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName
& "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(,
, xlR1C1))
If Err.Number <> 0 Then
'If the sheet named per first comment(QA)does not exist in
the workbook the row color will be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count +
1).Interior.Color = vbYellow

Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = _
"=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

'Add titles to columns and format to center some titles
Range("A1").FormulaR1C1 = "Workbook Name"
Range("B1").FormulaR1C1 = "Lot #"
Range("A1").Select

' Use AutoFit to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit

Cells.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "Workbook Name"
Range("A1").Select


With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
 
J

Joel

I opened the workbooks which I think is simplier than your appoach of using
formulas. I couldn't think of a good way of doing a find on a closed
workbook. Try this

Sub TagTeam_QA()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "QA" '<---- matches the name of the sheet to be searched
Set Rng = Range("D1,O20,O38") '<---- matches the specific cells to
'collect

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename( _
filefilter:="Excel Files,*.xl*", _
MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing

'Change ScreenUpdating and calculation to increase speed of macro
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 3
RwNum = 2

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
Set bk = Workbooks.Open(Filename:=FileNameXls(FNum))
found = False
For Each sht In bk.Sheets
If sht.Name = ShName Then
found = True
Exit For
End If
Next sht

If found = False Then
'If the sheet named per first comment(QA)does not exist in
'the workbook the row color will be Yellow.
SummWks.Rows(RwNum).Interior.Color = vbYellow
Else
With bk.Sheets(ShName)
Set c = .Cells.Find(what:="Lot", _
LookIn:=xlValues, loot:=xlPart)
If Not c Is Nothing Then
SummWks.Cells(RwNum, "B") = c.Offset(0, 2).Value
End If
colcount = 3
Set c = .Cells.Find(what:="Grand", _
LookIn:=xlValues, loot:=xlPart)
If Not c Is Nothing Then
firstaddr = c.Address
Do

SummWks.Cells(RwNum, colcount) = c.Offset(0, 1).Value
colcount = colcount + 1
Set c = .Cells.FindNext(after:=c)
Loop While Not c Is Nothing And c.Address <> firstaddr
End If

End With
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = _
"=" & PathStr & myCell.Address
Next myCell
End If

bk.Close savechanges:=False

Next FNum

With SummWks
'Add titles to columns and format to center some titles
.Range("A1") = "Workbook Name"
.Range("B1") = "Lot #"

' Use AutoFit to set the column width in the new workbook
.UsedRange.Columns.AutoFit
End With
End If
End Sub



John Yab said:
Could someone help me to modify the appended code from Ron de Bruins web
site, please? The values I really want to obtain are shown in the code
(namely in D1,O20,O38) but rather than hard coding D1,O20,O38 I would like to
use “find†and then “offset†to obtain them and use the code of “find†and
“offset†to replace: “Set Rng = Range("D1,O20,O38")â€. To restate this:
I would like to “find†the text: “Lot*†(located in B1) then offset 2
columns to the right to arrive at D1
I would like to “find†the text: “Grand*†(located in N20) then offset 1
column to the right to arrive at O20
I would like to “find†the text: “Grand*†(located in N38) then offset 1
column to the right to arrive at O38
This would allow for someone typing one of the key words of “Lot†or “Grandâ€
in a different cell but still return the value that is referenced by these
labels. Or if there is a better way than using “find†and “offset†then that
would be good too. The texts are actually: “Lot # :†and “Grand Average:†but
I was thinking to search with a wild card, * as sometimes the text is typed
slightly different, eg: Avg instead of Average. I am using Excel 2007 with
Vista. This is my first newsgroup post. Thanks, John Yab.

Sub TagTeam_QA()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "QA" '<---- matches the name of the sheet to be searched
Set Rng = Range("D1,O20,O38") '<---- matches the specific cells to
collect

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files,
*.xl*", MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing

'Change ScreenUpdating and calculation to increase speed of macro
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 3
RwNum = 2

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'",
"''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName
& "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(,
, xlR1C1))
If Err.Number <> 0 Then
'If the sheet named per first comment(QA)does not exist in
the workbook the row color will be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count +
1).Interior.Color = vbYellow

Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = _
"=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

'Add titles to columns and format to center some titles
Range("A1").FormulaR1C1 = "Workbook Name"
Range("B1").FormulaR1C1 = "Lot #"
Range("A1").Select

' Use AutoFit to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit

Cells.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "Workbook Name"
Range("A1").Select


With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
Click to expand...
 
J

John Yab

Hi Joel, Thanks for helping me. Unfortunately the code didn't work. Opening
the workbooks instead is okay. I changed 2 instances of "loot" to LookAt" and
then the code ran, but when I ran it, it returned 3 columns of zeros. I noted
that the part at the top still references the hard code of D1, O20, O38. The
first column for "Workbook Name" did not return any values. When I click in
the results in cell B3 for example the formula bar displays: =$D$1, so I
think it may be referening the sheet I am looking at instead of the sheets
from the searched files.
--
John Yab


Joel said:
I opened the workbooks which I think is simplier than your appoach of using
formulas. I couldn't think of a good way of doing a find on a closed
workbook. Try this

Sub TagTeam_QA()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "QA" '<---- matches the name of the sheet to be searched
Set Rng = Range("D1,O20,O38") '<---- matches the specific cells to
'collect

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename( _
filefilter:="Excel Files,*.xl*", _
MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing

'Change ScreenUpdating and calculation to increase speed of macro
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 3
RwNum = 2

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
Set bk = Workbooks.Open(Filename:=FileNameXls(FNum))
found = False
For Each sht In bk.Sheets
If sht.Name = ShName Then
found = True
Exit For
End If
Next sht

If found = False Then
'If the sheet named per first comment(QA)does not exist in
'the workbook the row color will be Yellow.
SummWks.Rows(RwNum).Interior.Color = vbYellow
Else
With bk.Sheets(ShName)
Set c = .Cells.Find(what:="Lot", _
LookIn:=xlValues, loot:=xlPart)
If Not c Is Nothing Then
SummWks.Cells(RwNum, "B") = c.Offset(0, 2).Value
End If
colcount = 3
Set c = .Cells.Find(what:="Grand", _
LookIn:=xlValues, loot:=xlPart)
If Not c Is Nothing Then
firstaddr = c.Address
Do

SummWks.Cells(RwNum, colcount) = c.Offset(0, 1).Value
colcount = colcount + 1
Set c = .Cells.FindNext(after:=c)
Loop While Not c Is Nothing And c.Address <> firstaddr
End If

End With
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = _
"=" & PathStr & myCell.Address
Next myCell
End If

bk.Close savechanges:=False

Next FNum

With SummWks
'Add titles to columns and format to center some titles
.Range("A1") = "Workbook Name"
.Range("B1") = "Lot #"

' Use AutoFit to set the column width in the new workbook
.UsedRange.Columns.AutoFit
End With
End If
End Sub



John Yab said:
Could someone help me to modify the appended code from Ron de Bruins web
site, please? The values I really want to obtain are shown in the code
(namely in D1,O20,O38) but rather than hard coding D1,O20,O38 I would like to
use “find†and then “offset†to obtain them and use the code of “find†and
“offset†to replace: “Set Rng = Range("D1,O20,O38")â€. To restate this:
I would like to “find†the text: “Lot*†(located in B1) then offset 2
columns to the right to arrive at D1
I would like to “find†the text: “Grand*†(located in N20) then offset 1
column to the right to arrive at O20
I would like to “find†the text: “Grand*†(located in N38) then offset 1
column to the right to arrive at O38
This would allow for someone typing one of the key words of “Lot†or “Grandâ€
in a different cell but still return the value that is referenced by these
labels. Or if there is a better way than using “find†and “offset†then that
would be good too. The texts are actually: “Lot # :†and “Grand Average:†but
I was thinking to search with a wild card, * as sometimes the text is typed
slightly different, eg: Avg instead of Average. I am using Excel 2007 with
Vista. This is my first newsgroup post. Thanks, John Yab.

Sub TagTeam_QA()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "QA" '<---- matches the name of the sheet to be searched
Set Rng = Range("D1,O20,O38") '<---- matches the specific cells to
collect

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files,
*.xl*", MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing

'Change ScreenUpdating and calculation to increase speed of macro
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 3
RwNum = 2

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'",
"''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName
& "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(,
, xlR1C1))
If Err.Number <> 0 Then
'If the sheet named per first comment(QA)does not exist in
the workbook the row color will be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count +
1).Interior.Color = vbYellow

Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = _
"=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

'Add titles to columns and format to center some titles
Range("A1").FormulaR1C1 = "Workbook Name"
Range("B1").FormulaR1C1 = "Lot #"
Range("A1").Select

' Use AutoFit to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit

Cells.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "Workbook Name"
Range("A1").Select


With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
Click to expand...
Click to expand...
 
J

Joel

I found two minor problems

1) I don't think your code wrote the filename in column A so I forgot to do
it.
2) I left a pie ce of you old code in themacro that was putting the formula
in the worksheet. I think my code was working and then your old code
over-wrote the data my code put in the workbook


Sub TagTeam_QA()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "QA" '<---- matches the name of the sheet to be searched
Set Rng = Range("D1,O20,O38") '<---- matches the specific cells to
'collect

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename( _
filefilter:="Excel Files,*.xl*", _
MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing

'Change ScreenUpdating and calculation to increase speed of macro
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 3
RwNum = 2

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
Set bk = Workbooks.Open(Filename:=FileNameXls(FNum))
SummWks.Range("A" & RwNum) = FileNameXls(FNum)
found = False
For Each sht In bk.Sheets
If sht.Name = ShName Then
found = True
Exit For
End If
Next sht

If found = False Then
'If the sheet named per first comment(QA)does not exist in
'the workbook the row color will be Yellow.
SummWks.Rows(RwNum).Interior.Color = vbYellow
Else
With bk.Sheets(ShName)
Set c = .Cells.Find(what:="Lot", _
LookIn:=xlValues, lookat:=xlPart)
If Not c Is Nothing Then
SummWks.Cells(RwNum, "B") = c.Offset(0, 2).Value
End If
colcount = 3
Set c = .Cells.Find(what:="Grand", _
LookIn:=xlValues, lookat:=xlPart)
If Not c Is Nothing Then
firstaddr = c.Address
Do

SummWks.Cells(RwNum, colcount) = c.Offset(0, 1).Value
colcount = colcount + 1
Set c = .Cells.FindNext(after:=c)
Loop While Not c Is Nothing And c.Address <> firstaddr
End If

End With
End If

bk.Close savechanges:=False

Next FNum

With SummWks
'Add titles to columns and format to center some titles
.Range("A1") = "Workbook Name"
.Range("B1") = "Lot #"

' Use AutoFit to set the column width in the new workbook
.UsedRange.Columns.AutoFit
End With
End If
End Sub



John Yab said:
Hi Joel, Thanks for helping me. Unfortunately the code didn't work. Opening
the workbooks instead is okay. I changed 2 instances of "loot" to LookAt" and
then the code ran, but when I ran it, it returned 3 columns of zeros. I noted
that the part at the top still references the hard code of D1, O20, O38. The
first column for "Workbook Name" did not return any values. When I click in
the results in cell B3 for example the formula bar displays: =$D$1, so I
think it may be referening the sheet I am looking at instead of the sheets
from the searched files.
--
John Yab


Joel said:
I opened the workbooks which I think is simplier than your appoach of using
formulas. I couldn't think of a good way of doing a find on a closed
workbook. Try this

Sub TagTeam_QA()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "QA" '<---- matches the name of the sheet to be searched
Set Rng = Range("D1,O20,O38") '<---- matches the specific cells to
'collect

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename( _
filefilter:="Excel Files,*.xl*", _
MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing

'Change ScreenUpdating and calculation to increase speed of macro
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 3
RwNum = 2

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
Set bk = Workbooks.Open(Filename:=FileNameXls(FNum))
found = False
For Each sht In bk.Sheets
If sht.Name = ShName Then
found = True
Exit For
End If
Next sht

If found = False Then
'If the sheet named per first comment(QA)does not exist in
'the workbook the row color will be Yellow.
SummWks.Rows(RwNum).Interior.Color = vbYellow
Else
With bk.Sheets(ShName)
Set c = .Cells.Find(what:="Lot", _
LookIn:=xlValues, loot:=xlPart)
If Not c Is Nothing Then
SummWks.Cells(RwNum, "B") = c.Offset(0, 2).Value
End If
colcount = 3
Set c = .Cells.Find(what:="Grand", _
LookIn:=xlValues, loot:=xlPart)
If Not c Is Nothing Then
firstaddr = c.Address
Do

SummWks.Cells(RwNum, colcount) = c.Offset(0, 1).Value
colcount = colcount + 1
Set c = .Cells.FindNext(after:=c)
Loop While Not c Is Nothing And c.Address <> firstaddr
End If

End With
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = _
"=" & PathStr & myCell.Address
Next myCell
End If

bk.Close savechanges:=False

Next FNum

With SummWks
'Add titles to columns and format to center some titles
.Range("A1") = "Workbook Name"
.Range("B1") = "Lot #"

' Use AutoFit to set the column width in the new workbook
.UsedRange.Columns.AutoFit
End With
End If
End Sub



John Yab said:
Could someone help me to modify the appended code from Ron de Bruins web
site, please? The values I really want to obtain are shown in the code
(namely in D1,O20,O38) but rather than hard coding D1,O20,O38 I would like to
use “find†and then “offset†to obtain them and use the code of “find†and
“offset†to replace: “Set Rng = Range("D1,O20,O38")â€. To restate this:
I would like to “find†the text: “Lot*†(located in B1) then offset 2
columns to the right to arrive at D1
I would like to “find†the text: “Grand*†(located in N20) then offset 1
column to the right to arrive at O20
I would like to “find†the text: “Grand*†(located in N38) then offset 1
column to the right to arrive at O38
This would allow for someone typing one of the key words of “Lot†or “Grandâ€
in a different cell but still return the value that is referenced by these
labels. Or if there is a better way than using “find†and “offset†then that
would be good too. The texts are actually: “Lot # :†and “Grand Average:†but
I was thinking to search with a wild card, * as sometimes the text is typed
slightly different, eg: Avg instead of Average. I am using Excel 2007 with
Vista. This is my first newsgroup post. Thanks, John Yab.

Sub TagTeam_QA()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "QA" '<---- matches the name of the sheet to be searched
Set Rng = Range("D1,O20,O38") '<---- matches the specific cells to
collect

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files,
*.xl*", MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing

'Change ScreenUpdating and calculation to increase speed of macro
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 3
RwNum = 2

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'",
"''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName
& "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(,
, xlR1C1))
If Err.Number <> 0 Then
'If the sheet named per first comment(QA)does not exist in
the workbook the row color will be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count +
1).Interior.Color = vbYellow

Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = _
"=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

'Add titles to columns and format to center some titles
Range("A1").FormulaR1C1 = "Workbook Name"
Range("B1").FormulaR1C1 = "Lot #"
Range("A1").Select

' Use AutoFit to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit

Cells.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "Workbook Name"
Range("A1").Select


With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
Click to expand...
Click to expand...
Click to expand...
 
J

John Yab

Thanks Joel,

It's almost perfect now. The only minor thing left is that column A
populates with the full path. How do I trim it so it is just the file name?
(just from the last \ to the right end?
--
John Yab


Joel said:
I found two minor problems

1) I don't think your code wrote the filename in column A so I forgot to do
it.
2) I left a pie ce of you old code in themacro that was putting the formula
in the worksheet. I think my code was working and then your old code
over-wrote the data my code put in the workbook


Sub TagTeam_QA()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "QA" '<---- matches the name of the sheet to be searched
Set Rng = Range("D1,O20,O38") '<---- matches the specific cells to
'collect

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename( _
filefilter:="Excel Files,*.xl*", _
MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing

'Change ScreenUpdating and calculation to increase speed of macro
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 3
RwNum = 2

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
Set bk = Workbooks.Open(Filename:=FileNameXls(FNum))
SummWks.Range("A" & RwNum) = FileNameXls(FNum)
found = False
For Each sht In bk.Sheets
If sht.Name = ShName Then
found = True
Exit For
End If
Next sht

If found = False Then
'If the sheet named per first comment(QA)does not exist in
'the workbook the row color will be Yellow.
SummWks.Rows(RwNum).Interior.Color = vbYellow
Else
With bk.Sheets(ShName)
Set c = .Cells.Find(what:="Lot", _
LookIn:=xlValues, lookat:=xlPart)
If Not c Is Nothing Then
SummWks.Cells(RwNum, "B") = c.Offset(0, 2).Value
End If
colcount = 3
Set c = .Cells.Find(what:="Grand", _
LookIn:=xlValues, lookat:=xlPart)
If Not c Is Nothing Then
firstaddr = c.Address
Do

SummWks.Cells(RwNum, colcount) = c.Offset(0, 1).Value
colcount = colcount + 1
Set c = .Cells.FindNext(after:=c)
Loop While Not c Is Nothing And c.Address <> firstaddr
End If

End With
End If

bk.Close savechanges:=False

Next FNum

With SummWks
'Add titles to columns and format to center some titles
.Range("A1") = "Workbook Name"
.Range("B1") = "Lot #"

' Use AutoFit to set the column width in the new workbook
.UsedRange.Columns.AutoFit
End With
End If
End Sub



John Yab said:
Hi Joel, Thanks for helping me. Unfortunately the code didn't work. Opening
the workbooks instead is okay. I changed 2 instances of "loot" to LookAt" and
then the code ran, but when I ran it, it returned 3 columns of zeros. I noted
that the part at the top still references the hard code of D1, O20, O38. The
first column for "Workbook Name" did not return any values. When I click in
the results in cell B3 for example the formula bar displays: =$D$1, so I
think it may be referening the sheet I am looking at instead of the sheets
from the searched files.
--
John Yab


Joel said:
I opened the workbooks which I think is simplier than your appoach of using
formulas. I couldn't think of a good way of doing a find on a closed
workbook. Try this

Sub TagTeam_QA()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "QA" '<---- matches the name of the sheet to be searched
Set Rng = Range("D1,O20,O38") '<---- matches the specific cells to
'collect

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename( _
filefilter:="Excel Files,*.xl*", _
MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing

'Change ScreenUpdating and calculation to increase speed of macro
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 3
RwNum = 2

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
Set bk = Workbooks.Open(Filename:=FileNameXls(FNum))
found = False
For Each sht In bk.Sheets
If sht.Name = ShName Then
found = True
Exit For
End If
Next sht

If found = False Then
'If the sheet named per first comment(QA)does not exist in
'the workbook the row color will be Yellow.
SummWks.Rows(RwNum).Interior.Color = vbYellow
Else
With bk.Sheets(ShName)
Set c = .Cells.Find(what:="Lot", _
LookIn:=xlValues, loot:=xlPart)
If Not c Is Nothing Then
SummWks.Cells(RwNum, "B") = c.Offset(0, 2).Value
End If
colcount = 3
Set c = .Cells.Find(what:="Grand", _
LookIn:=xlValues, loot:=xlPart)
If Not c Is Nothing Then
firstaddr = c.Address
Do

SummWks.Cells(RwNum, colcount) = c.Offset(0, 1).Value
colcount = colcount + 1
Set c = .Cells.FindNext(after:=c)
Loop While Not c Is Nothing And c.Address <> firstaddr
End If

End With
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = _
"=" & PathStr & myCell.Address
Next myCell
End If

bk.Close savechanges:=False

Next FNum

With SummWks
'Add titles to columns and format to center some titles
.Range("A1") = "Workbook Name"
.Range("B1") = "Lot #"

' Use AutoFit to set the column width in the new workbook
.UsedRange.Columns.AutoFit
End With
End If
End Sub



:

Could someone help me to modify the appended code from Ron de Bruins web
site, please? The values I really want to obtain are shown in the code
(namely in D1,O20,O38) but rather than hard coding D1,O20,O38 I would like to
use “find†and then “offset†to obtain them and use the code of “find†and
“offset†to replace: “Set Rng = Range("D1,O20,O38")â€. To restate this:
I would like to “find†the text: “Lot*†(located in B1) then offset 2
columns to the right to arrive at D1
I would like to “find†the text: “Grand*†(located in N20) then offset 1
column to the right to arrive at O20
I would like to “find†the text: “Grand*†(located in N38) then offset 1
column to the right to arrive at O38
This would allow for someone typing one of the key words of “Lot†or “Grandâ€
in a different cell but still return the value that is referenced by these
labels. Or if there is a better way than using “find†and “offset†then that
would be good too. The texts are actually: “Lot # :†and “Grand Average:†but
I was thinking to search with a wild card, * as sometimes the text is typed
slightly different, eg: Avg instead of Average. I am using Excel 2007 with
Vista. This is my first newsgroup post. Thanks, John Yab.

Sub TagTeam_QA()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "QA" '<---- matches the name of the sheet to be searched
Set Rng = Range("D1,O20,O38") '<---- matches the specific cells to
collect

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files,
*.xl*", MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing

'Change ScreenUpdating and calculation to increase speed of macro
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 3
RwNum = 2

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'",
"''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName
& "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(,
, xlR1C1))
If Err.Number <> 0 Then
'If the sheet named per first comment(QA)does not exist in
the workbook the row color will be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count +
1).Interior.Color = vbYellow

Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
Click to expand...
Click to expand...
Click to expand...
 
J

Joel

from
SummWks.Range("A" & RwNum) = FileNameXls(FNum)
to
BaseName = FileNameXls(FNum)
BaseName = mid(BaseName,instrrev(BaseName,"\") + 1)
SummWks.Range("A" & RwNum) = BaseName


John Yab said:
Thanks Joel,

It's almost perfect now. The only minor thing left is that column A
populates with the full path. How do I trim it so it is just the file name?
(just from the last \ to the right end?
--
John Yab


Joel said:
I found two minor problems

1) I don't think your code wrote the filename in column A so I forgot to do
it.
2) I left a pie ce of you old code in themacro that was putting the formula
in the worksheet. I think my code was working and then your old code
over-wrote the data my code put in the workbook


Sub TagTeam_QA()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "QA" '<---- matches the name of the sheet to be searched
Set Rng = Range("D1,O20,O38") '<---- matches the specific cells to
'collect

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename( _
filefilter:="Excel Files,*.xl*", _
MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing

'Change ScreenUpdating and calculation to increase speed of macro
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 3
RwNum = 2

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
Set bk = Workbooks.Open(Filename:=FileNameXls(FNum))
SummWks.Range("A" & RwNum) = FileNameXls(FNum)
found = False
For Each sht In bk.Sheets
If sht.Name = ShName Then
found = True
Exit For
End If
Next sht

If found = False Then
'If the sheet named per first comment(QA)does not exist in
'the workbook the row color will be Yellow.
SummWks.Rows(RwNum).Interior.Color = vbYellow
Else
With bk.Sheets(ShName)
Set c = .Cells.Find(what:="Lot", _
LookIn:=xlValues, lookat:=xlPart)
If Not c Is Nothing Then
SummWks.Cells(RwNum, "B") = c.Offset(0, 2).Value
End If
colcount = 3
Set c = .Cells.Find(what:="Grand", _
LookIn:=xlValues, lookat:=xlPart)
If Not c Is Nothing Then
firstaddr = c.Address
Do

SummWks.Cells(RwNum, colcount) = c.Offset(0, 1).Value
colcount = colcount + 1
Set c = .Cells.FindNext(after:=c)
Loop While Not c Is Nothing And c.Address <> firstaddr
End If

End With
End If

bk.Close savechanges:=False

Next FNum

With SummWks
'Add titles to columns and format to center some titles
.Range("A1") = "Workbook Name"
.Range("B1") = "Lot #"

' Use AutoFit to set the column width in the new workbook
.UsedRange.Columns.AutoFit
End With
End If
End Sub



John Yab said:
Hi Joel, Thanks for helping me. Unfortunately the code didn't work. Opening
the workbooks instead is okay. I changed 2 instances of "loot" to LookAt" and
then the code ran, but when I ran it, it returned 3 columns of zeros. I noted
that the part at the top still references the hard code of D1, O20, O38. The
first column for "Workbook Name" did not return any values. When I click in
the results in cell B3 for example the formula bar displays: =$D$1, so I
think it may be referening the sheet I am looking at instead of the sheets
from the searched files.
--
John Yab


:

I opened the workbooks which I think is simplier than your appoach of using
formulas. I couldn't think of a good way of doing a find on a closed
workbook. Try this

Sub TagTeam_QA()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "QA" '<---- matches the name of the sheet to be searched
Set Rng = Range("D1,O20,O38") '<---- matches the specific cells to
'collect

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename( _
filefilter:="Excel Files,*.xl*", _
MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing

'Change ScreenUpdating and calculation to increase speed of macro
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 3
RwNum = 2

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
Set bk = Workbooks.Open(Filename:=FileNameXls(FNum))
found = False
For Each sht In bk.Sheets
If sht.Name = ShName Then
found = True
Exit For
End If
Next sht

If found = False Then
'If the sheet named per first comment(QA)does not exist in
'the workbook the row color will be Yellow.
SummWks.Rows(RwNum).Interior.Color = vbYellow
Else
With bk.Sheets(ShName)
Set c = .Cells.Find(what:="Lot", _
LookIn:=xlValues, loot:=xlPart)
If Not c Is Nothing Then
SummWks.Cells(RwNum, "B") = c.Offset(0, 2).Value
End If
colcount = 3
Set c = .Cells.Find(what:="Grand", _
LookIn:=xlValues, loot:=xlPart)
If Not c Is Nothing Then
firstaddr = c.Address
Do

SummWks.Cells(RwNum, colcount) = c.Offset(0, 1).Value
colcount = colcount + 1
Set c = .Cells.FindNext(after:=c)
Loop While Not c Is Nothing And c.Address <> firstaddr
End If

End With
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = _
"=" & PathStr & myCell.Address
Next myCell
End If

bk.Close savechanges:=False

Next FNum

With SummWks
'Add titles to columns and format to center some titles
.Range("A1") = "Workbook Name"
.Range("B1") = "Lot #"

' Use AutoFit to set the column width in the new workbook
.UsedRange.Columns.AutoFit
End With
End If
End Sub



:

Could someone help me to modify the appended code from Ron de Bruins web
site, please? The values I really want to obtain are shown in the code
(namely in D1,O20,O38) but rather than hard coding D1,O20,O38 I would like to
use “find†and then “offset†to obtain them and use the code of “find†and
“offset†to replace: “Set Rng = Range("D1,O20,O38")â€. To restate this:
I would like to “find†the text: “Lot*†(located in B1) then offset 2
columns to the right to arrive at D1
I would like to “find†the text: “Grand*†(located in N20) then offset 1
column to the right to arrive at O20
I would like to “find†the text: “Grand*†(located in N38) then offset 1
column to the right to arrive at O38
This would allow for someone typing one of the key words of “Lot†or “Grandâ€
in a different cell but still return the value that is referenced by these
labels. Or if there is a better way than using “find†and “offset†then that
would be good too. The texts are actually: “Lot # :†and “Grand Average:†but
I was thinking to search with a wild card, * as sometimes the text is typed
slightly different, eg: Avg instead of Average. I am using Excel 2007 with
Vista. This is my first newsgroup post. Thanks, John Yab.

Sub TagTeam_QA()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "QA" '<---- matches the name of the sheet to be searched
Set Rng = Range("D1,O20,O38") '<---- matches the specific cells to
collect

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files,
*.xl*", MultiSelect:=True)

If IsArray(FileNameXls) = False Then
'do nothing

'Change ScreenUpdating and calculation to increase speed of macro
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 3
RwNum = 2

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'",
"''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName
& "'!"

On Error Resume Next
Click to expand...
Click to expand...
Click to expand...
 
J

John Yab

Thank you. It works perfectly. I can't thank you enough. For me as a newbie
to the newsgroups getting an answer to this problem is terrific. I am
inspired by the whole process.
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

How to change this Ron deBruin Macro 10
Trouble selecting multiple sheets using RDB code 13
Create macro button 1
VBA does not work 1
GetOpen filename to open files(Workbooks) 11
Modifying Ron De Bruin's "Create summary sheet from different workbooks" 7
Excel Data Combine 3
Ron - Summary_cells_from_Different_Workbooks_2 9

Top