-
Notifications
You must be signed in to change notification settings - Fork 11
/
Copy pathExcel VBA - Collect files.vb
60 lines (46 loc) · 1.78 KB
/
Excel VBA - Collect files.vb
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
Sub collectWorkbooks()
Dim wb As Workbook
Set wb = ActiveWorkbook
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim folder As Object
Dim fullFilePath As String
' Get the active workbook path
Dim wbPath As String
wbPath = wb.Path
' Get the folder of the current workbook
Set folder = fso.GetFolder(wbPath)
Dim openedWb As Workbook
Dim currentSheet As Worksheet
Dim newWs As Worksheet
Dim sourceRange As Range
Dim destinationRange As Range
Dim currentWs As Worksheet
originalScreenUpdating = Application.ScreenUpdating
Application.ScreenUpdating = False
For Each file In folder.Files
If InStr(1, file.Name, "Rapport", vbTextCompare) = 0 Then
' Build the worksheet path
fullFilePath = openedWsPath & "\" & file.Name
' Open the worksheet
Set openedWb = Workbooks.Open(file.Name)
' Get the first sheet
Set currentWs = openedWb.Worksheets(1)
Set sourceRange = currentWs.Range("A1:N300")
' Create a new sheet in this current workbook
wb.Sheets.Add
Set newWs = wb.Sheets(1)
' newWs.Select
newWs.Name = Replace(file.Name, ".csv", "")
' Copy the data from the source range to the destination range
Set destinationRange = newWs.Range("A1:N300")
sourceRange.Copy destinationRange
' Close and release the opened worksheet
openedWb.Close SaveChanges:=False
Set openedWb = Nothing
Set newWs = Nothing
Set sourceRange = Nothing
End If
Next file
Application.ScreenUpdating = originalScreenUpdating
End Sub