N
new_to_vba
Hi,
when i enter FileName under "A6", lets say the Filename is Template,
it will search through all the drive in the PC,example C:\ , D:\ , F:\
and it will then
copy the data of all the Filename with "Template", example "Template
1,Template 2, Template 3"
after copying the data, it will then display a messagebox "P/T
Updated"
my codes are shown below
Code:
--------------------
Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'dimension variables
Dim wb As Workbook, wsDest1 As Worksheet, wsDest2 As Worksheet
Dim ws1 As Worksheet, Ws2 As Worksheet, i As Long, Pos As Long
Dim Folder As String, File As String, Path As String
'folder to loop through
Folder = "F:\FYP week12\samples" 'replace with the correct folder name
'set destination info
Set wsDest1 = ActiveWorkbook.Sheets(1)
'Start FileSearch
With Application.FileSearch
.LookIn = Folder
.Filename = [a7] & "*.xls"
.FileType = msoFileTypeExcelWorkbooks
.SearchSubFolders = False
.Execute
If .Execute > 0 Then
'loop through all found files
For i = 1 To .FoundFiles.Count
'set incidental variables
Pos = InStrRev(.FoundFiles(i), "\")
File = Right(.FoundFiles(i), Len(.FoundFiles(i)) - Pos)
Path = Left(.FoundFiles(i), Pos)
'check if workbook is open. if so, set variable to it, else open it
If IsWbOpen(File) Then
Set wb = Workbooks(File)
Else
Set wb = Workbooks.Open(Path & File)
End If
'set worksheets to copy data from
Set ws1 = wb.Sheets(1)
'copy data
ws1.Range("D9:CP9").Copy 'change the range to copy
With wsDest1.Cells(Rows.Count, 2).End(xlUp).Offset(1)
.PasteSpecial (xlValues)
.PasteSpecial (xlFormats)
'.PasteSpecial xlValues
End With
wb.Close
Next i
End If
End With
Set wsDest1 = Nothing: Set wsDest2 = Nothing: Set ws1 = Nothing
Set Ws2 = Nothing: Set wb = Nothing
Application.ScreenUpdating = False
Application.DisplayAlerts = False
End Sub
Function IsWbOpen(wbName As String) As Boolean
On Error Resume Next
IsWbOpen = Len(Workbooks(wbName).Name)
End Function
when i enter FileName under "A6", lets say the Filename is Template,
it will search through all the drive in the PC,example C:\ , D:\ , F:\
and it will then
copy the data of all the Filename with "Template", example "Template
1,Template 2, Template 3"
after copying the data, it will then display a messagebox "P/T
Updated"
my codes are shown below
Code:
--------------------
Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'dimension variables
Dim wb As Workbook, wsDest1 As Worksheet, wsDest2 As Worksheet
Dim ws1 As Worksheet, Ws2 As Worksheet, i As Long, Pos As Long
Dim Folder As String, File As String, Path As String
'folder to loop through
Folder = "F:\FYP week12\samples" 'replace with the correct folder name
'set destination info
Set wsDest1 = ActiveWorkbook.Sheets(1)
'Start FileSearch
With Application.FileSearch
.LookIn = Folder
.Filename = [a7] & "*.xls"
.FileType = msoFileTypeExcelWorkbooks
.SearchSubFolders = False
.Execute
If .Execute > 0 Then
'loop through all found files
For i = 1 To .FoundFiles.Count
'set incidental variables
Pos = InStrRev(.FoundFiles(i), "\")
File = Right(.FoundFiles(i), Len(.FoundFiles(i)) - Pos)
Path = Left(.FoundFiles(i), Pos)
'check if workbook is open. if so, set variable to it, else open it
If IsWbOpen(File) Then
Set wb = Workbooks(File)
Else
Set wb = Workbooks.Open(Path & File)
End If
'set worksheets to copy data from
Set ws1 = wb.Sheets(1)
'copy data
ws1.Range("D9:CP9").Copy 'change the range to copy
With wsDest1.Cells(Rows.Count, 2).End(xlUp).Offset(1)
.PasteSpecial (xlValues)
.PasteSpecial (xlFormats)
'.PasteSpecial xlValues
End With
wb.Close
Next i
End If
End With
Set wsDest1 = Nothing: Set wsDest2 = Nothing: Set ws1 = Nothing
Set Ws2 = Nothing: Set wb = Nothing
Application.ScreenUpdating = False
Application.DisplayAlerts = False
End Sub
Function IsWbOpen(wbName As String) As Boolean
On Error Resume Next
IsWbOpen = Len(Workbooks(wbName).Name)
End Function