M
Mike Taylor
I gather business results from multiple users in Excel workbooks. The
workbooks are identical in every respect except for file name and, of
course, results data users enter for their respective businesses. All
of the workbooks and worksheets are protected. My objective is to
utylize VBA code that will when exectued:
1) Prompt me to select the directory where the user workbooks are
located, then
2) Loop through each of the workbooks in that directory and copy data
from the same range each of those source workbooks into my active
workbook, and
3) Rename each copied worksheet using a three digit numeric value
"000" in cell "d2" of each worksheet that has been copied. The name of
the copied worksheets would thus be 001, 002, 003, etc., then
4) No changes are saved to the source workbooks once the data copy
action is completed and the source worksheets and workbooks remain
protected with no loss of data when they are closed.
For more than a month I have pieced together snipets of code (see
below) which seems to almost achieve my purpose. What I really want is
to copy only cell values and formats from each of the source
worksheets without copying all of the worksheets with underlying
formulas. It would suffice if I could
copy cell values and formats from specific ranges from the source
worksheets rather than copying the entire source worksheet (i.e.,
three or four ranges, for example: Row2 thru Row5, b6:f29, k6:k29, and
m6:m29). I just don't know how to tweak the code to do that.
I appreciate any advise as to how to copy only cell values and formats
from the multiple sources worksheets rather than to copy the entire
worksheet. Would someone be kind enough to help me with code ideas or
recommendations?
TIA,
Mike Taylor, Enthusiastic Beginner
------------------------------------------------------------------
Sub GetSheets()
Dim i As Long
Dim varr As Variant
Dim wkbk As Workbook
Dim sh As Object
Dim mybook As Workbook
Dim myExistingPath As String
Dim myPathToRetrieve As String
myExistingPath = CurDir
myPathToRetrieve = "c:\data\datafiles\jan"
ChDrive myPathToRetrieve
ChDir myPathToRetrieve
varr = Application.GetOpenFilename(filefilter:="Excel Files, *.xls", _
MultiSelect:=True)
If IsArray(varr) Then
For i = LBound(varr) To UBound(varr)
Set wkbk = Workbooks.Open(varr(i))
With wkbk.Worksheets("Results Report 2004")
On Error Resume Next
'For i = 1 To .FoundFiles.Count
Set mybook = Workbooks.Open(.FoundFiles(i))
For Each sh In mybook.Sheets
ActiveWorkbook.Unprotect ("mbt")
ActiveSheet.Unprotect ("mbt")
Next sh
mybook.Close SaveChanges:=False
'Next i
.Name = .Range("d2").Value
'If Err.Number <> 0 Then
'MsgBox .Name & " Couldn't be renamed"
'Err.Clear
'End If
.UsedRange.Value = .UsedRange.Value
.Copy after:=ThisWorkbook. _
Worksheets(ThisWorkbook.Worksheets.Count)
ActiveSheet.Name = Format(123, "000") 'testing
worksheet name - delete if not working
End With
wkbk.Close SaveChanges:=False
Next
End If
'reset it back
ChDrive myExistingPath
ChDir myExistingPath
End Sub
workbooks are identical in every respect except for file name and, of
course, results data users enter for their respective businesses. All
of the workbooks and worksheets are protected. My objective is to
utylize VBA code that will when exectued:
1) Prompt me to select the directory where the user workbooks are
located, then
2) Loop through each of the workbooks in that directory and copy data
from the same range each of those source workbooks into my active
workbook, and
3) Rename each copied worksheet using a three digit numeric value
"000" in cell "d2" of each worksheet that has been copied. The name of
the copied worksheets would thus be 001, 002, 003, etc., then
4) No changes are saved to the source workbooks once the data copy
action is completed and the source worksheets and workbooks remain
protected with no loss of data when they are closed.
For more than a month I have pieced together snipets of code (see
below) which seems to almost achieve my purpose. What I really want is
to copy only cell values and formats from each of the source
worksheets without copying all of the worksheets with underlying
formulas. It would suffice if I could
copy cell values and formats from specific ranges from the source
worksheets rather than copying the entire source worksheet (i.e.,
three or four ranges, for example: Row2 thru Row5, b6:f29, k6:k29, and
m6:m29). I just don't know how to tweak the code to do that.
I appreciate any advise as to how to copy only cell values and formats
from the multiple sources worksheets rather than to copy the entire
worksheet. Would someone be kind enough to help me with code ideas or
recommendations?
TIA,
Mike Taylor, Enthusiastic Beginner
------------------------------------------------------------------
Sub GetSheets()
Dim i As Long
Dim varr As Variant
Dim wkbk As Workbook
Dim sh As Object
Dim mybook As Workbook
Dim myExistingPath As String
Dim myPathToRetrieve As String
myExistingPath = CurDir
myPathToRetrieve = "c:\data\datafiles\jan"
ChDrive myPathToRetrieve
ChDir myPathToRetrieve
varr = Application.GetOpenFilename(filefilter:="Excel Files, *.xls", _
MultiSelect:=True)
If IsArray(varr) Then
For i = LBound(varr) To UBound(varr)
Set wkbk = Workbooks.Open(varr(i))
With wkbk.Worksheets("Results Report 2004")
On Error Resume Next
'For i = 1 To .FoundFiles.Count
Set mybook = Workbooks.Open(.FoundFiles(i))
For Each sh In mybook.Sheets
ActiveWorkbook.Unprotect ("mbt")
ActiveSheet.Unprotect ("mbt")
Next sh
mybook.Close SaveChanges:=False
'Next i
.Name = .Range("d2").Value
'If Err.Number <> 0 Then
'MsgBox .Name & " Couldn't be renamed"
'Err.Clear
'End If
.UsedRange.Value = .UsedRange.Value
.Copy after:=ThisWorkbook. _
Worksheets(ThisWorkbook.Worksheets.Count)
ActiveSheet.Name = Format(123, "000") 'testing
worksheet name - delete if not working
End With
wkbk.Close SaveChanges:=False
Next
End If
'reset it back
ChDrive myExistingPath
ChDir myExistingPath
End Sub