Though I do not know VBA I managed to adapt Ron de Bruins code as follows. It
does what I want thus far. I now wish to have an additional condition i.e.IF
Consol!D2=1 Application.Run €œCopyToSh5€� , IF Consol!D2=2, Application.Run
€œCopyToSh6€�,IF Consol!D2=3,Application.Run €œCopyToSh7€�, etc upto 10. Any help
from the ng will be appreciated.. Also would it be possible to select the
files from a list (named range €œSALES€�) in the Main Sheet rather than an
onscreen selection

Sub GetData_Example3()
Dim SaveDriveDir As String, MyPath As String
Dim FName As Variant, N As Long
Dim destrange As Range
Dim sh As Worksheet
Application.Run "DeleteConsol"
SaveDriveDir = CurDir
MyPath = Application.DefaultFilePath 'or use "C:\Data"
ChDrive MyPath
ChDir MyPath
FName = Application.GetOpenFilename(filefilter:="Excel Files,*.xls", _
MultiSelect:=True)
If IsArray(FName) Then
FName = Array_Sort(FName)

Application.ScreenUpdating = False
Set sh = ActiveWorkbook.Worksheets.Add
sh.Name = "Consol"
For N = LBound(FName) To UBound(FName)

Set destrange = sh.Cells(1, 1)
GetData FName(N), "Sheet1", "A1:D6", destrange, True
Application.Run "CopyToSh5"
Next
End If
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub
=============================
Sub CopyToSh5()
'
' Macro recorded 11/12/2005 by Robert
Sheets("Consol").Select
Range("A1:D6").Select
Selection.Copy
Sheets("Sheet5").Select

Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd,
SkipBlanks _
:=False, Transpose:=False
End Sub
================================================== =
Sub DeleteConsol()
' Macro recorded 11/12/2005 by Robert
Sheets("Consol").Select
ActiveWindow.SelectedSheets.Delete
Sheets("Sheet5").Select
Selection.Clear
End Sub

--
Robert

You can loop through a list like so. I haven't tested this but it seems to
be what you ask

Application.ScreenUpdating = False
Set sh2 = Worksheets("Sheet2")
iLastRow = sh2.Cells(sh2.Rows.Count,"A").End(xlUp).Row
For i = 1 To iLastRow
sFilename = sh2.Cells(i,"A").Row
Set sh = ActiveWorkbook.Worksheets.Add
sh.Name = "Consol"
Set destrange = sh.Cells(1, 1)
GetData sFilename, "Sheet1", "A1:D6", destrange, True
Select Case Consol!D2
Case1 : Application.Run "CopyToSh5"
Case 2: Application.Run "CopyToSh6",
Case 3: Application.Run "CopyToSh7"
'etc.
End Select
End If


--

HTH

RP
(remove nothere from the email address if mailing direct)


"Robert" wrote in message
...
Though I do not know VBA I managed to adapt Ron de Bruins code as follows.
It
does what I want thus far. I now wish to have an additional condition
i.e.IF
Consol!D2=1 Application.Run "CopyToSh5" , IF Consol!D2=2, Application.Run
"CopyToSh6",IF Consol!D2=3,Application.Run "CopyToSh7", etc upto 10. Any
help
from the ng will be appreciated.. Also would it be possible to select the
files from a list (named range "SALES") in the Main Sheet rather than an
onscreen selection

Sub GetData_Example3()
Dim SaveDriveDir As String, MyPath As String
Dim FName As Variant, N As Long
Dim destrange As Range
Dim sh As Worksheet
Application.Run "DeleteConsol"
SaveDriveDir = CurDir
MyPath = Application.DefaultFilePath 'or use "C:\Data"
ChDrive MyPath
ChDir MyPath
FName = Application.GetOpenFilename(filefilter:="Excel Files,*.xls", _
MultiSelect:=True)
If IsArray(FName) Then
FName = Array_Sort(FName)

Application.ScreenUpdating = False
Set sh = ActiveWorkbook.Worksheets.Add
sh.Name = "Consol"
For N = LBound(FName) To UBound(FName)

Set destrange = sh.Cells(1, 1)
GetData FName(N), "Sheet1", "A1:D6", destrange, True
Application.Run "CopyToSh5"
Next
End If
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub
=============================
Sub CopyToSh5()
'
' Macro recorded 11/12/2005 by Robert
Sheets("Consol").Select
Range("A1:D6").Select
Selection.Copy
Sheets("Sheet5").Select

Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd,
SkipBlanks _
:=False, Transpose:=False
End Sub
================================================== =
Sub DeleteConsol()
' Macro recorded 11/12/2005 by Robert
Sheets("Consol").Select
ActiveWindow.SelectedSheets.Delete
Sheets("Sheet5").Select
Selection.Clear
End Sub

--
Robert

Thanks Bob for the fast response. I seem to have a problem.
When executing, I get a comple error "variable not defined" and
"sh2=" (your second line of code) is highlighted in blue. I have also
removed a coma after"CopyToSh6". I don't mind continuing to select
the files onscreen so long as the conditional posting to the respective
worksheets can be done.
--
Robert


"Bob Phillips" wrote:

You can loop through a list like so. I haven't tested this but it seems to
be what you ask

Application.ScreenUpdating = False
Set sh2 = Worksheets("Sheet2")
iLastRow = sh2.Cells(sh2.Rows.Count,"A").End(xlUp).Row
For i = 1 To iLastRow
sFilename = sh2.Cells(i,"A").Row
Set sh = ActiveWorkbook.Worksheets.Add
sh.Name = "Consol"
Set destrange = sh.Cells(1, 1)
GetData sFilename, "Sheet1", "A1:D6", destrange, True
Select Case Consol!D2
Case1 : Application.Run "CopyToSh5"
Case 2: Application.Run "CopyToSh6",
Case 3: Application.Run "CopyToSh7"
'etc.
End Select
End If


--

HTH

RP
(remove nothere from the email address if mailing direct)


"Robert" wrote in message
...
Though I do not know VBA I managed to adapt Ron de Bruins code as follows.
It
does what I want thus far. I now wish to have an additional condition
i.e.IF
Consol!D2=1 Application.Run "CopyToSh5" , IF Consol!D2=2, Application.Run
"CopyToSh6",IF Consol!D2=3,Application.Run "CopyToSh7", etc upto 10. Any
help
from the ng will be appreciated.. Also would it be possible to select the
files from a list (named range "SALES") in the Main Sheet rather than an
onscreen selection

Sub GetData_Example3()
Dim SaveDriveDir As String, MyPath As String
Dim FName As Variant, N As Long
Dim destrange As Range
Dim sh As Worksheet
Application.Run "DeleteConsol"
SaveDriveDir = CurDir
MyPath = Application.DefaultFilePath 'or use "C:\Data"
ChDrive MyPath
ChDir MyPath
FName = Application.GetOpenFilename(filefilter:="Excel Files,*.xls", _
MultiSelect:=True)
If IsArray(FName) Then
FName = Array_Sort(FName)

Application.ScreenUpdating = False
Set sh = ActiveWorkbook.Worksheets.Add
sh.Name = "Consol"
For N = LBound(FName) To UBound(FName)

Set destrange = sh.Cells(1, 1)
GetData FName(N), "Sheet1", "A1:D6", destrange, True
Application.Run "CopyToSh5"
Next
End If
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub
=============================
Sub CopyToSh5()
'
' Macro recorded 11/12/2005 by Robert
Sheets("Consol").Select
Range("A1:D6").Select
Selection.Copy
Sheets("Sheet5").Select

Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd,
SkipBlanks _
:=False, Transpose:=False
End Sub
================================================== =
Sub DeleteConsol()
' Macro recorded 11/12/2005 by Robert
Sheets("Consol").Select
ActiveWindow.SelectedSheets.Delete
Sheets("Sheet5").Select
Selection.Clear
End Sub

--
Robert

You need to declare the extra variables in your code

Dim sh2 As Worksheet
Dim iLastRow As Long

Add that and try this correction

Application.ScreenUpdating = False
Set sh2 = Worksheets("Sheet2")
iLastRow = sh2.Cells(sh2.Rows.Count, "A").End(xlUp).Row
For i = 1 To iLastRow
sFileName = sh2.Cells(i, "A").Row
Set sh = ActiveWorkbook.Worksheets.Add
sh.Name = "Consol"
Set destrange = sh.Cells(1, 1)
'GetData sFileName, "Sheet1", "A1:D6", destrange, True
Select Case Consol!D2
Case 1: Application.Run "CopyToSh5"
Case 2: Application.Run "CopyToSh6"
Case 3: Application.Run "CopyToSh7"
'etc.
End Select
Next i



--

HTH

RP
(remove nothere from the email address if mailing direct)


"Robert" wrote in message
...
Thanks Bob for the fast response. I seem to have a problem.
When executing, I get a comple error "variable not defined" and
"sh2=" (your second line of code) is highlighted in blue. I have also
removed a coma after"CopyToSh6". I don't mind continuing to select
the files onscreen so long as the conditional posting to the respective
worksheets can be done.
--
Robert


"Bob Phillips" wrote:

You can loop through a list like so. I haven't tested this but it seems
to
be what you ask

Application.ScreenUpdating = False
Set sh2 = Worksheets("Sheet2")
iLastRow = sh2.Cells(sh2.Rows.Count,"A").End(xlUp).Row
For i = 1 To iLastRow
sFilename = sh2.Cells(i,"A").Row
Set sh = ActiveWorkbook.Worksheets.Add
sh.Name = "Consol"
Set destrange = sh.Cells(1, 1)
GetData sFilename, "Sheet1", "A1:D6", destrange, True
Select Case Consol!D2
Case1 : Application.Run "CopyToSh5"
Case 2: Application.Run "CopyToSh6",
Case 3: Application.Run "CopyToSh7"
'etc.
End Select
End If


--

HTH

RP
(remove nothere from the email address if mailing direct)


"Robert" wrote in message
...
Though I do not know VBA I managed to adapt Ron de Bruins code as
follows.
It
does what I want thus far. I now wish to have an additional condition
i.e.IF
Consol!D2=1 Application.Run "CopyToSh5" , IF Consol!D2=2,
Application.Run
"CopyToSh6",IF Consol!D2=3,Application.Run "CopyToSh7", etc upto 10.
Any
help
from the ng will be appreciated.. Also would it be possible to select
the
files from a list (named range "SALES") in the Main Sheet rather than
an
onscreen selection

Sub GetData_Example3()
Dim SaveDriveDir As String, MyPath As String
Dim FName As Variant, N As Long
Dim destrange As Range
Dim sh As Worksheet
Application.Run "DeleteConsol"
SaveDriveDir = CurDir
MyPath = Application.DefaultFilePath 'or use "C:\Data"
ChDrive MyPath
ChDir MyPath
FName = Application.GetOpenFilename(filefilter:="Excel
Files,*.xls", _
MultiSelect:=True)
If IsArray(FName) Then
FName = Array_Sort(FName)

Application.ScreenUpdating = False
Set sh = ActiveWorkbook.Worksheets.Add
sh.Name = "Consol"
For N = LBound(FName) To UBound(FName)

Set destrange = sh.Cells(1, 1)
GetData FName(N), "Sheet1", "A1:D6", destrange, True
Application.Run "CopyToSh5"
Next
End If
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub
=============================
Sub CopyToSh5()
'
' Macro recorded 11/12/2005 by Robert
Sheets("Consol").Select
Range("A1:D6").Select
Selection.Copy
Sheets("Sheet5").Select

Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd,
SkipBlanks _
:=False, Transpose:=False
End Sub
================================================== =
Sub DeleteConsol()
' Macro recorded 11/12/2005 by Robert
Sheets("Consol").Select
ActiveWindow.SelectedSheets.Delete
Sheets("Sheet5").Select
Selection.Clear
End Sub

--
Robert

Using new code as below. Error "i" (marked**) "not declared".
When "Dim i As Long" (????) was added, sFileName (next row)
became "not declared". Thank you for your patience, perhaps
one more try?.Please check if my ending is correct.
Sub GetData_Example3()
Dim SaveDriveDir As String, MyPath As String
Dim FName As Variant, N As Long
Dim destrange As Range
Dim sh As Worksheet
Dim sh2 As Worksheet
Dim iLastRow As Long

Application.Run "DeleteConsol"
SaveDriveDir = CurDir
MyPath = Application.DefaultFilePath 'or use "C:\Data"
ChDrive MyPath
ChDir MyPath
FName = Application.GetOpenFilename(filefilter:="Excel Files,*.xls", _
MultiSelect:=True)
If IsArray(FName) Then
FName = Array_Sort(FName)

Application.ScreenUpdating = False
Set sh2 = Worksheets("Sheet2")
iLastRow = sh2.Cells(sh2.Rows.Count, "A").End(xlUp).Row
** For i = 1 To iLastRow
sFileName = sh2.Cells(i, "A").Row
Set sh = ActiveWorkbook.Worksheets.Add
sh.Name = "Consol"
Set destrange = sh.Cells(1, 1)
'GetData sFileName, "Sheet1", "A1:D6", destrange, True
Select Case Consol!D2
Case 1: Application.Run "CopyToSh5"
Case 2: Application.Run "CopyToSh6"
Case 3: Application.Run "CopyToSh7"
'etc.
End Select
Next i
End Sub

--
Robert

Sub GetData_Example3()
Dim SaveDriveDir As String, MyPath As String
Dim FName As Variant, N As Long
Dim destrange As Range
Dim sh As Worksheet
Dim sh2 As Worksheet
Dim iLastRow As Long
Dim i As Long
Dim sFilename As String
Application.Run "DeleteConsol"
SaveDriveDir = CurDir
MyPath = Application.DefaultFilePath 'or use "C:\Data"
ChDrive MyPath
ChDir MyPath
Application.ScreenUpdating = False
Set sh2 = Worksheets("Sheet2")
iLastRow = sh2.Cells(sh2.Rows.Count, "A").End(xlUp).Row
For i = 1 To iLastRow
sFilename = sh2.Cells(i, "A").Row
Set sh = ActiveWorkbook.Worksheets.Add
sh.Name = "Consol"
Set destrange = sh.Cells(1, 1)
GetData sFilename, "Sheet1", "A1:D6", destrange, True
Select Case Worksheets("Consol").Range("D2")
Case 1: Application.Run "CopyToSh5"
Case 2: Application.Run "CopyToSh6"
Case 3: Application.Run "CopyToSh7"
'etc.
End Select
Next i
End Sub


--

HTH

RP
(remove nothere from the email address if mailing direct)


"Robert" wrote in message
...
Using new code as below. Error "i" (marked**) "not declared".
When "Dim i As Long" (????) was added, sFileName (next row)
became "not declared". Thank you for your patience, perhaps
one more try?.Please check if my ending is correct.
Sub GetData_Example3()
Dim SaveDriveDir As String, MyPath As String
Dim FName As Variant, N As Long
Dim destrange As Range
Dim sh As Worksheet
Dim sh2 As Worksheet
Dim iLastRow As Long

Application.Run "DeleteConsol"
SaveDriveDir = CurDir
MyPath = Application.DefaultFilePath 'or use "C:\Data"
ChDrive MyPath
ChDir MyPath
FName = Application.GetOpenFilename(filefilter:="Excel Files,*.xls", _
MultiSelect:=True)
If IsArray(FName) Then
FName = Array_Sort(FName)

Application.ScreenUpdating = False
Set sh2 = Worksheets("Sheet2")
iLastRow = sh2.Cells(sh2.Rows.Count, "A").End(xlUp).Row
** For i = 1 To iLastRow
sFileName = sh2.Cells(i, "A").Row
Set sh = ActiveWorkbook.Worksheets.Add
sh.Name = "Consol"
Set destrange = sh.Cells(1, 1)
'GetData sFileName, "Sheet1", "A1:D6", destrange, True
Select Case Consol!D2
Case 1: Application.Run "CopyToSh5"
Case 2: Application.Run "CopyToSh6"
Case 3: Application.Run "CopyToSh7"
'etc.
End Select
Next i
End Sub

--
Robert