Hello,
I have code which allows me to select a folder and extract data from all the files in that folder into a new excel spreadsheet.
However, each file contains links and I have to decline the update of links manually during running of the code which is very repetitive for over 1000 imports
I have tried adding this code into mine to break the links so the code runs with no intervention. I'm not having much success and getting lots of errors and am really stuck, can anyone help please?
My code that works is here:
I have code which allows me to select a folder and extract data from all the files in that folder into a new excel spreadsheet.
However, each file contains links and I have to decline the update of links manually during running of the code which is very repetitive for over 1000 imports
I have tried adding this code into mine to break the links so the code runs with no intervention. I'm not having much success and getting lots of errors and am really stuck, can anyone help please?
Code:
Dim astrLinks As Variant, i As Integer
' Define variable as an Excel link type.
astrLinks = Workbooks(sNewBook).LinkSources(Type:=xlLinkTypeExcelLinks)
For i = UBound(astrLinks) To 1 Step -1
' Break each link in the new workbook.
Workbooks(sNewBook).BreakLink _
Name:=astrLinks(i), _
Type:=xlLinkTypeExcelLinks
NextMy code that works is here:
Code:
Sub SAP_Data()
Dim fs, f, f1, fc, s, FilePath
Dim lngCount As Long
Dim DataStor(400, 3) As Variant
' Set error trapping
On Error GoTo ErrorHandler:
' Open the file dialog
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = True
.Show
' Display paths of each file selected
For lngCount = 1 To .SelectedItems.Count
EndofPath = InStrRev(.SelectedItems(lngCount), "\")
FilePath = Left(.SelectedItems(lngCount), EndofPath)
Next lngCount
End With
Range("A1").Select
CD_Worksheet = ActiveCell.Worksheet.Name
ActiveCell.Select
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(FilePath)
Set fc = f.Files
counter = 0
For Each f1 In fc
ExcelFile = f1.Name
Workbooks.Open Filename:=FilePath & ExcelFile
' Determine the Asset and open the appropriate spreadsheet to insert data into
RWI_code = Left(ActiveCell.Worksheet.Name, 3)
Worksheet_Name = ActiveCell.Worksheet.Name
Data_File = "" ' Initialise
Select Case RWI_code
Case 101, 102, 103, 108, 109
Data_File = "Area 1"
Case 202 To 209
Data_File = "Area 2"
Case 301 To 303
Data_File = "Area 3"
Case 401, 403
Data_File = "Area 4"
Case 501 To 509
Data_File = "Area 5"
Case 601 To 611
Data_File = "Area 6"
Case 701 To 710
Data_File = "Area 7"
End Select
On Error Resume Next
Workbooks.Open Filename:="C:\Documents and Settings\roswald\Desktop\TEST\New Folder\" & Data_File
Worksheets(RWI_code).Activate
If Err.Number = 0 Then
' Store Data Headings
Range("A3").Select
ActiveCell.Select
Erase DataStor
DataComplete = False
rowcnt = 0
section = ""
Heading = ""
Do While Not DataComplete
If ActiveCell.Offset(-2, 0).Value <> "" Then section = ActiveCell.Offset(-2, 0).Value
If ActiveCell.Offset(-1, 0).Value = "" Then
Heading = ActiveCell.Value
Else
Heading = ActiveCell.Offset(-1, 0).Value
End If
DataStor(rowcnt, 0) = section
DataStor(rowcnt, 1) = Heading
DataStor(rowcnt, 2) = ActiveCell.Value
rowcnt = rowcnt + 1
ActiveCell.Offset(0, 1).Activate
If ActiveCell.Offset(0, 0).Value = "" Then DataComplete = True
Loop
' Switch to SAP sheet and extract data
Windows(ExcelFile).Activate
rowcnt = 0
section = ""
Do While DataStor(rowcnt, 0) <> ""
If section <> DataStor(rowcnt, 0) Then
section = DataStor(rowcnt, 0)
Cells.Find(What:=section, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
).Activate
CellRef = ActiveCell.Address
End If
Select Case section
Case "1.4 Project Notes"
Cells.Find(What:=DataStor(rowcnt, 1), After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
).Activate
ActiveCell.Select
counter = 1
activerow = 1
Do While counter <= 4
DataStor(rowcnt, 3) = ActiveCell.Offset(activerow, 0).Value
DataStor(rowcnt + 1, 3) = ActiveCell.Offset(activerow, 2).Value
DataStor(rowcnt + 2, 3) = ActiveCell.Offset(activerow, 5).Value
rowcnt = rowcnt + 3
counter = counter + 1
activerow = activerow + 3
Loop
DataStor(rowcnt, 3) = ActiveCell.Offset(14, 0).Value
rowcnt = rowcnt + 1
Case Else ' Lookup values
On Error Resume Next ' in case data not found
Cells.Find(What:=DataStor(rowcnt, 1), After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
).Activate
If Err.Number = 0 Then
ActiveCell.Select
DataStor(rowcnt, 3) = ActiveCell.Offset(0, 1).Value
End If
rowcnt = rowcnt + 1
End Select
Loop
' Determine the first blank row in Data sheet prior to inserting the data
Windows(Data_File & ".xls").Activate
Range("A4").Select
ActiveCell.Select
Do While ActiveCell.Value <> ""
ActiveCell.Offset(1, 0).Activate
Loop
' Transfer values to Data spreadsheet
rowcnt = 0
Do While DataStor(rowcnt, 0) <> ""
ActiveCell.Value = DataStor(rowcnt, 3)
ActiveCell.Offset(0, 1).Activate
rowcnt = rowcnt + 1
Loop
Workbooks(Data_File & ".xls").Close SaveChanges:=True ' Close Data Template
Else
Msg = "Unable to find Data template for " & Worksheet_Name _
& " - called by SAP sheet - " & ExcelFile
MsgBox Msg
End If
Workbooks(ExcelFile).Close SaveChanges:=False ' Close SAP sheet
Next
Exit Sub ' Exit to avoid handler.
ErrorHandler: ' Error-handling routine.
Select Case Err.Number ' Evaluate where error occurred
Case 53
Msg = "Unable to find spreadsheet " & SAP_File & ".xls"
MsgBox Msg
Exit Sub
Case Else
' Handle other situations here...
Msg = "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
Exit Sub
End Select
End Sub