Related
I am trying to generate CSV files from a set of records from Excel.
Column A is the file name and the rest of the columns are the data to write to the the file.
As of now, I am using WriteLine, but it doesn't work as expected:
As you can see, I don't get the expected output. How do I get the expected output?
Private Sub ommandButton1_Click()
Dim Path As String
Dim Folder As String
Dim Answer As VbMsgBoxResult
Path = "C:\Access Permissions\Users"
Folder = Dir(Path, vbDirectory)
If Folder = vbNullString Then
'-------------Create Folder -----------------------
MkDir ("C:\Access Permissions")
MkDir ("C:\Access Permissions\Roles")
MkDir ("C:\Access Permissions\Users")
Else
Set rngSource = Range("A4", Range("A" & Rows.Count).End(xlUp))
rngSource.Copy Range("AA1")
Range("AA:AA").RemoveDuplicates Columns:=1, Header:=xlNo
Set rngUnique = Range("AA1", Range("AA" & Rows.Count).End(xlUp))
Set lr = Cells(rngSource.Rows.Count, rngSource.Column)
Set fso = CreateObject("Scripting.FileSystemObject")
For Each cell In rngUnique
n = Application.CountIf(rngSource, cell.Value)
Set C = rngSource.Find(cell.Value, lookat:=xlWhole, after:=lr)
Set oFile = fso.CreateTextFile("C:\Access Permissions\Users\" & cell.Value & "-Users.csv")
For i = 1 To n
oFile.WriteLine C.Offset(0, 1).Value
oFile.WriteLine C.Offset(0, 2).Value
oFile.WriteLine C.Offset(0, 3).Value
oFile.WriteLine C.Offset(0, 4).Value
oFile.WriteLine C.Offset(0, 6).Value
oFile.WriteLine C.Offset(0, 7).Value
Set C = rngSource.FindNext(C)
Next i
Next cell
rngUnique.ClearContents
MsgBox "Individual Users.csv files got generated" & vbCrLf & " " & vbCrLf & "Path - C:\Access Permissions\Groups "
End If
End Sub
Updated Image:
Let me re-phrase my questions.
Updated Image Enclosed.
Using the Data Set [Updated Image point 1], It creates unique CSV files based on column A.
File got saved at the path given.
As of now the row data associated with each file name got written in the files but in a new line manner.
As expected, how the output can be written in Columns.[ Updated Image Point 4]
Given code is working without any error.
5.1. I just need to click twice if the Path folder does not exist.
5.2. at first click, it creates the Folder at the given path.
5.3. at Second click it generates the unique files, with its records.
If you can please guide me on how the records can be written in columns [ Updated Image Point 4 ], expected output.
Download File
I assume your data does not contain any semicolons.
You are writing each field on a line by itself. Instead, join the fields on a single line:
oFile.WriteLine C.Offset(0, 1).Value & ";" & _
C.Offset(0, 2).Value & ";" & _
C.Offset(0, 3).Value & ";" & _
C.Offset(0, 4).Value & ";" & _
C.Offset(0, 6).Value & ";" & _
C.Offset(0, 7).Value
There are other bugs in your example; it should not work as far as I can see. For example, you keep opening the same file with CreateTextFile. You should only create a file once, not every time you write to it. According to the documentation, you should get an error on your second try, see CreateTextFile method. The reason you don't get an error is probably because you never close the file. You should close the files you create.
I would use this approach instead:
' Collect the data for each file into a dictionary.
' The cells in the table must not contain semicolons.
Sub Doit()
Dim Sht As Worksheet
Dim Rng As Range
Dim LastRowNum As Long, LastColNum As Long
Dim Lst As Variant, Hdr As Variant, Elem As Variant
Dim Idx As Long, Idx2 As Long
Dim Dct As Object
Dim HdrTxt, Txt As String, Sep As String
Dim Filename As String
Set Sht = ActiveSheet
' Get the last row in column 1
Set Rng = Sht.Cells(Sht.Rows.Count, 1).End(xlUp)
LastRowNum = Rng.Row
' Get the last column in row 3
Set Rng = Sht.Cells(3, Sht.Columns.Count).End(xlToLeft)
LastColNum = Rng.Column
' Get the headers in row 3
Set Rng = Sht.Range(Sht.Cells(3, 1), Sht.Cells(3, LastColNum))
Hdr = Rng
' Create a semicolon seprated line for the headers
HdrTxt = ""
Sep = ""
For Idx = LBound(Hdr, 2) To UBound(Hdr, 2)
HdrTxt = HdrTxt & Sep & Hdr(1, Idx)
Sep = ";"
Next Idx
HdrTxt = HdrTxt & vbNewLine
' Get the data from row 4 and down
Set Rng = Sht.Range(Sht.Cells(4, 1), Sht.Cells(LastRowNum, LastColNum))
Lst = Rng
' Store the data for each file in a dicitonary
Set Dct = CreateObject("Scripting.Dictionary")
For Idx = LBound(Lst) To UBound(Lst)
Filename = Lst(Idx, 1)
' Create a semicolon seprated line
Txt = ""
Sep = ""
For Idx2 = LBound(Lst, 2) To UBound(Lst, 2)
Txt = Txt & Sep & Lst(Idx, Idx2)
Sep = ";"
Next Idx2
Txt = Txt & vbNewLine
' Add the line to the dictionary
If Dct.Exists(Filename) Then
Dct(Filename) = Dct(Filename) & Txt
Else
Dct(Filename) = HdrTxt & Txt
End If
Next Idx
' Output data for each file to the immdiate window
For Each Elem In Dct
' Change this to open the file and write the contents
Debug.Print "---- Filename: " & Elem
Debug.Print Dct(Elem)
Next Elem
End Sub
The example makes sure you only create the files once:
Change the last loop For Each Elem In Dct that prints the data to the immediate window, to create a file instead. Use the Write method instead of the WriteLine method, as the data already contains the line-breaks. And remember to Close the files.
I think this is what you want.
Sub Copy_To_Workbooks()
'Note: This macro use the function LastRow
Dim My_Range As Range
Dim FieldNum As Long
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim CalcMode As Long
Dim ViewMode As Long
Dim ws2 As Worksheet
Dim MyPath As String
Dim foldername As String
Dim Lrow As Long
Dim cell As Range
Dim CCount As Long
Dim WSNew As Worksheet
Dim ErrNum As Long
'Set filter range on ActiveSheet: A1 is the top left cell of your filter range
'and the header of the first column, D is the last column in the filter range.
'You can also add the sheet name to the code like this :
'Worksheets("Sheet1").Range("A1:D" & LastRow(Worksheets("Sheet1")))
'No need that the sheet is active then when you run the macro when you use this.
Set My_Range = Range("A1:B" & LastRow(ActiveSheet))
My_Range.Parent.Select
If ActiveWorkbook.ProtectStructure = True Or _
My_Range.Parent.ProtectContents = True Then
MsgBox "Sorry, not working when the workbook or worksheet is protected", _
vbOKOnly, "Copy to new workbook"
Exit Sub
End If
'This example filters on the first column in the range(change the field if needed)
'In this case the range starts in A so Field:=1 is column A, 2 = column B, ......
FieldNum = 1
'Turn off AutoFilter
My_Range.Parent.AutoFilterMode = False
'Set the file extension/format
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".txt": FileFormatNum = -4143
Else
'You use Excel 2007-2010
If ActiveWorkbook.FileFormat = 56 Then
FileExtStr = ".txt": FileFormatNum = 56
Else
FileExtStr = ".txt": FileFormatNum = 51
End If
End If
'Change ScreenUpdating, Calculation, EnableEvents, ....
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
ActiveSheet.DisplayPageBreaks = False
'Delete the sheet RDBLogSheet if it exists
On Error Resume Next
Application.DisplayAlerts = False
Sheets("RDBLogSheet").Delete
Application.DisplayAlerts = True
On Error GoTo 0
' Add worksheet to copy/Paste the unique list
Set ws2 = Worksheets.Add(After:=Sheets(Sheets.Count))
ws2.Name = "RDBLogSheet"
'Fill in the path\folder where you want the new folder with the files
'you can use also this "C:\Users\Ron\test"
MyPath = "C:\Users\ryans\OneDrive\Desktop\"
'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'Create folder for the new files
foldername = MyPath & Format(Now, "yyyy-mm-dd hh-mm-ss") & "\"
MkDir foldername
With ws2
'first we copy the Unique data from the filter field to ws2
My_Range.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("A3"), Unique:=True
'loop through the unique list in ws2 and filter/copy to a new sheet
Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each cell In .Range("A4:A" & Lrow)
'Filter the range
My_Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _
Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?")
'Check if there are no more then 8192 areas(limit of areas)
CCount = 0
On Error Resume Next
CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible) _
.Areas(1).Cells.Count
On Error GoTo 0
If CCount = 0 Then
MsgBox "There are more than 8192 areas for the value : " & cell.Value _
& vbNewLine & "It is not possible to copy the visible data." _
& vbNewLine & "Tip: Sort your data before you use this macro.", _
vbOKOnly, "Split in worksheets"
Else
'Add new workbook with one sheet
Set WSNew = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
'Copy/paste the visible data to the new workbook
My_Range.SpecialCells(xlCellTypeVisible).Copy
With WSNew.Range("A1")
' Paste:=8 will copy the columnwidth in Excel 2000 and higher
' Remove this line if you use Excel 97
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
End With
'Save the file in the new folder and close it
On Error Resume Next
ChDir MyPath
ActiveWorkbook.SaveAs Filename:= _
foldername & cell.Value & ".txt", _
FileFormat:=xlTextMSDOS, CreateBackup:=False
If Err.Number > 0 Then
Err.Clear
ErrNum = ErrNum + 1
WSNew.Parent.SaveAs foldername & _
"Error_" & Format(ErrNum, "0000") & FileExtStr, FileFormatNum
.Cells(cell.Row, "B").Formula = "=Hyperlink(""" & foldername & _
"Error_" & Format(ErrNum, "0000") & FileExtStr & """)"
.Cells(cell.Row, "A").Interior.Color = vbRed
Else
.Cells(cell.Row, "B").Formula = _
"=Hyperlink(""" & foldername & cell.Value & FileExtStr & """)"
End If
WSNew.Parent.Close False
On Error GoTo 0
End If
'Show all the data in the range
My_Range.AutoFilter Field:=FieldNum
Next cell
.Cells(1, "A").Value = "Red cell: can't use the Unique name as file name"
.Cells(1, "B").Value = "Created Files (Click on the link to open a file)"
.Cells(3, "A").Value = "Unique Values"
.Cells(3, "B").Value = "Full Path and File name"
.Cells(3, "A").Font.Bold = True
.Cells(3, "B").Font.Bold = True
.Columns("A:B").AutoFit
End With
'Turn off AutoFilter
My_Range.Parent.AutoFilterMode = False
If ErrNum > 0 Then
MsgBox "Rename every WorkSheet name that start with ""Error_"" manually" _
& vbNewLine & "There are characters in the name that are not allowed" _
& vbNewLine & "in a sheet name or the worksheet already exist."
End If
'Restore ScreenUpdating, Calculation, EnableEvents, ....
My_Range.Parent.Select
ActiveWindow.View = ViewMode
ws2.Select
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Before:
After:
I'm trying to attach files and store them in cells G2 and on.
However, every time I input it gets input in G2. If a user decides to enter more data the input data will iterate into a new row but the attachment stays in row G2 and takes the place of the previous one.
textbox2 in userform gets skipped every time I press enter. I want my users to navigate with keyboards but if I'm done in textbox1 and press enter it will throw me to textbox3 rather than textbox2.
Private Sub SubmitButton_Click()
Dim iRow As Long
Dim wrkSht As Worksheet
Set wrkSht = Worksheets("Sheet1")
Dim emailApplication As Object
Dim emailItem As Object
iRow = wrkSht.Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
If Trim(RequesterBox.Value) = "" Then
RequesterBox.SetFocus
MsgBox "Please complete the form"
Exit Sub
End If
wrkSht.Cells(iRow, 1).Value = RequesterBox.Value
wrkSht.Cells(iRow, 2).Value = SquadronBox.Value
wrkSht.Cells(iRow, 3).Value = EmailBox.Value
wrkSht.Cells(iRow, 4).Value = PhoneBox.Value
wrkSht.Cells(iRow, 5).Value = LocationBox.Value
wrkSht.Cells(iRow, 6).Value = DescriptionBox.Value
MsgBox "Request has been added Succesfully. Thanks for you submition, someone will be contacting you shortly", vbOKOnly + vbInformation, "Thanks"
'----------------------- Send Email-----------------------'
Set emailApplication = CreateObject("Outlook.Application")
Set emailItem = emailApplication.CreateItem(0)
emailItem.To = ""
emailItem.Subject = "Facility Request"
emailItem.Body = "A request for " & LocationBox.Value & " has been submited with the following description: " & Chr(10) & _
DescriptionBox.Value
emailItem.Display
Set emailItem = Nothing
Set emailItemApplication = Nothing
RequesterBox.Value = ""
SquadronBox.Value = ""
EmailBox.Value = ""
PhoneBox.Value = ""
LocationBox.Value = ""
DescriptionBox.Value = ""
RequesterBox.SetFocus
End Sub
Private Sub AttachButton_Click()
Set wrkSht = Worksheets("Sheet1")
Dim LinksList As Range
Dim iRow As Long
Dim LinkAttached As Long
Set LinksList = Range("G2")
Sheet1.Range("G2").Select
'declare last row to insert link to
lastRowLink = WorksheetFunction.CountA(Sheets("Sheet1").Range("G:G"))
Sheets("Sheet1").Cells(lastRow + 1, 11).Value = LinkAttached
ChDrive "C:\"
ChDir "C:\"
Filt = "PNG Files(*.png),*.png ," & _
"Jpeg Files(*.jpeg),*.jpg ," & _
"PDF Files (*.pdf),*.pdf ," & _
"All Files (*.*),*.*"
FilterIndex = 1
Title = "Select a File to Hyperlink"
FileName = Application.GetOpenFilename _
(FileFilter:=Filt, _
FilterIndex:=FilterIndex, _
Title:=Title)
If FileName <> False Then
wrkSht.Hyperlinks.Add Anchor:=LinksList, _
Address:=FileName, _
TextToDisplay:=FileName
Else
MsgBox "No file was selected.", vbCritical, "Loading Error"
Exit Sub
End If
End Sub
Hy i hope it will help you
Private Sub AttachButton2_Click()
Dim lastRow As Long, nextId As Long
Dim ws As Worksheet
Dim newRecord As Range
Set ws = ThisWorkbook.Worksheets("Sheet1")
With ws
'getlcurrent last row
lastRow = .Cells(.Rows.Count, "G").End(xlUp).Row
'get next Id
nextId = Val(.Range("G" & lastRow).Value) + 1
'set new record
Set newRecord = .Range("G" & lastRow + 1)
'insert data
newRecord.Value = nextId
'select file
ChDrive "C:\"
ChDir "C:\"
Filt = "PNG Files(*.png),*.png ," & _
"Jpeg Files(*.jpeg),*.jpg ," & _
"PDF Files (*.pdf),*.pdf ," & _
"All Files (*.*),*.*"
FilterIndex = 1
Title = "Select a File to Hyperlink"
Filename = Application.GetOpenFilename _
(FileFilter:=Filt, _
FilterIndex:=FilterIndex, _
Title:=Title)
If Filename <> False Then
.Hyperlinks.Add Anchor:=newRecord, _
Address:=Filename, _
TextToDisplay:=Filename
Else
MsgBox "No file was selected.", vbCritical, "Loading Error"
Exit Sub
End If
End With
End Sub
I am working on a big project and the ability to change the code stopped at this point. So help is needed please.
The main folders have subfolders and MSR files inside which are related to eachother with the naming.We have to input this main folder path into D4 on our excel file.
The MSR have all the info related to every image. Image folders have all the images inside and we need to sort the all into subfolders.
We already have a macro that retrieves a list on which images are correlated to the correct position. ( see third image)
What we want do now is creating subfolders into the main folder that corresponds to the "*test" in this case and in this new folder there should be subfolders created based on how many unique places there are. In this case it would result in 18 subfolder. The combination of Column D and E are the unique places (first 2 examples = 13200-9496 and 13213-9506). All the image files that corrospond to this place should be put in the new subfolder.
I hope this is somewhat clear?
Main folder overview
Sub folder overview
Output data
Code:
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim WBMacro As Workbook
Set WBMacro = ActiveWorkbook
Dim FoName As Range
Set FoName = WBMacro.Sheets("Instructions").Range("B4")
FolderName = FoName
If Right(FolderName, 1) <> Application.PathSeparator Then FolderName = FolderName & Application.PathSeparator
FName = Dir(FolderName & "*.msr")
'loop through the files
Do While Len(FName)
Dim WBMSR As Workbook
Set WBMSR = Workbooks.Open(FolderName & FName)
With WBMSR
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True
'Create new tab to copy data of interest in
Dim WsMSR As Worksheet
Set WsMSR = WBMSR.ActiveSheet
WsMSR.Name = "MSRData"
.Worksheets.Add
Dim wsPictData As Worksheet
Set wsPictData = WBMSR.Sheets("Sheet1")
wsPictData.Name = "PictureInfo"
'Define where to copy data to
Dim RngPictName As Range
Dim RngX As Range
Dim RngY As Range
Set RngPictName = wsPictData.Range("A2")
Set RngXY = wsPictData.Range("B2")
Set RngChipCoX = wsPictData.Range("D2")
Set RngChipCoY = wsPictData.Range("E2")
RngPictName.Offset(-1, 0) = "PictName"
RngXY.Offset(-1, 0) = "DieX,DieY"
RngChipCoX.Offset(-1, 0) = "ChipCoX"
RngChipCoY.Offset(-1, 0) = "ChipCoY"
'Find PictureName
Dim RngPictStart As Range
Dim RngPictStop As Range
Dim RngPict As Range
Dim strImage As String
strImage = "&mp_image_name"
Dim strChipNr As String
strChipNr = "Chip_number"
Dim strChipCo As String
strChipCo = "Chip_coordinate"
With WsMSR.Range("B:B")
Set image = .Find(strImage, lookat:=xlPart, LookIn:=xlValues)
If Not image Is Nothing Then
FirstAddress = image.Address
Do
Set pict = image.Offset(0, 2)
pict.Copy
If RngPictName = "" Then
RngPictName.PasteSpecial
Else
RngPictName.Offset(-1, 0).End(xlDown).Offset(1, 0).PasteSpecial
End If
For i = 1 To 15
'Do
If image.Offset(i, 1).Value = strChipNr Then
Set XY = image.Offset(i, 2)
XY.Copy
If RngXY = "" Then
RngXY.PasteSpecial
Else
RngXY.Offset(-1, 0).End(xlDown).Offset(1, 0).PasteSpecial
End If
End If
If image.Offset(i, 1).Value = strChipCo Then
Set ChipX = image.Offset(i, 2)
ChipX.Copy
If RngChipCoX = "" Then
RngChipCoX.PasteSpecial
Else
RngChipCoX.Offset(-1, 0).End(xlDown).Offset(1, 0).PasteSpecial
End If
Set ChipY = image.Offset(i, 4)
ChipY.Copy
If RngChipCoY = "" Then
RngChipCoY.PasteSpecial
Else
RngChipCoY.Offset(-1, 0).End(xlDown).Offset(1, 0).PasteSpecial
End If
End If
Next
Set image = .FindNext(image)
If image Is Nothing Then
GoTo DoneFinding1
End If
Loop While image.Address <> FirstAddress
End If
End With
DoneFinding1:
End With
' change wsPictData Column B with (x,Y) to 2 columns (B = X, C = Y)
With wsPictData
Columns("B:B").Select
Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True
End With
WsMSR.Delete
Dim WBMSRFileName As String
WBMSRFileName = Left(WBMSR.Name, Len(WBMSR.Name) - 4)
Dim relativePath As String
relativePath = WBMSR.Path
WBMSR.SaveAs Filename:=relativePath & "\" & "Pictures_" & WBMSRFileName & ".xlsx", FileFormat:=xlOpenXMLWorkbook
WBMSR.Close (False)
' go to the next file in the folder
FName = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox ("all Files in folder" & relativePath & " are analyzed")
This is a schema to clarify the folder tree. Picture test is the main folder (in this example, name is always different). The grey area on the bottom is wat the macro needs to make. Inside Mainfolder, create for every "test" a new folder with appendix "filtered" and in every folder new folders with the location which hold all the images that were taken on that location.
folder tree
msr file example
This scans the MAIN_FOLDER for excel files starting with Pictures_, opens them and scans down the rows building the destination folder names from columns A, D and E. I put message boxes at each stage so if you single step through you can study how it works. It will create sub-folders if you confirm the action but the actual copy method at the end is commented out. See FileSystemObject for more details.
Sub imagemove()
Const MAIN_FOLDER = "c:\temp\msr\"
Dim FileName As String, wb As Workbook, ws As Worksheet
Dim count As Long, iLastRow As Long, iRow As Long
Dim sPictureFolder As String, sCopyFolder As String
Dim sCopySubFolder As String, msg As String
Dim sPictureName As String, sChipCoX As String, sChipCoY As String
Dim sSrc As String, sDest As String
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
FileName = Dir(MAIN_FOLDER & "Pictures_*.xlsx")
Do While Len(FileName) > 0
' determine picture folder from filename
sPictureFolder = MAIN_FOLDER & Mid(FileName, 10, Len(FileName) - 14)
sCopyFolder = sPictureFolder & "-Filtered"
Debug.Print sPictureFolder, sCopyFolder
' check if folder exists
If FSO.FolderExists(sCopyFolder) = False Then
msg = sCopyFolder & " does not exist, do you want to create it"
If vbYes = MsgBox(msg, vbYesNo, "Confirm") Then
FSO.CreateFolder sCopyFolder
Else
Exit Sub
End If
End If
' scan down msr file
Set wb = Workbooks.Open(MAIN_FOLDER & FileName, False, True)
Set ws = wb.Sheets("PictureInfo")
iLastRow = ws.Cells(Rows.count, 1).End(xlUp).Row
'Debug.Print FileName, iLastRow
For iRow = 2 To iLastRow
sPictureName = ws.Cells(iRow, 1) ' A
sChipCoX = ws.Cells(iRow, 4) ' D
sChipCoY = ws.Cells(iRow, 5) ' E
' ignore jpeg images
If Right(sPictureName, 4) = "jpeg" Then GoTo skip
sCopySubFolder = sCopyFolder & "\" & sChipCoX & "-" & sChipCoY
' check if sub folder exists
If FSO.FolderExists(sCopySubFolder) = False Then
msg = sCopySubFolder & " does not exist, do you want to create it"
If vbYes = MsgBox(msg, vbYesNo, "Confirm") Then
FSO.CreateFolder sCopySubFolder
Else
Exit Sub
End If
End If
' move locations
sSrc = sPictureFolder & "\" & sPictureName
sDest = sCopySubFolder & "\" & sPictureName
' check file exists
If FSO.FileExists(sSrc) = True Then
MsgBox "Copy from " & sSrc & " to " & sDest
'FSO.CopyFile sSrc, sDest
Else
MsgBox sSrc & " does not exist", vbCritical, "File does not exist"
'test FSO.CreateTextFile sDest
End If
Debug.Print "Copy", sSrc, "to", sDest
skip:
Next
count = count + 1
FileName = Dir
Loop
MsgBox count & " Pictures_* files scanned in " & MAIN_FOLDER, vbInformation
End Sub
Ok, I have to answer my question... I deleted all the jpeg files from the Pictures file so these images are not copied so I created another loop. I first had it inside your loop but then it would create an extra extra empty folder. But now I`m afraid that I slowed down the macro by a lot? Is it better to do it inside your loop and then delete the "-" folder in the end?
Set wb = Workbooks.Open(MAIN_FOLDER & "\" & FileName, False, True)
Set ws = wb.Sheets("PictureInfo")
iLastRow = ws.Cells(Rows.count, 1).End(xlUp).Row
'Debug.Print FileName, iLastRow
For iRow = 2 To sLastrow
If Right(ws.Cells(iRow, 1).Text, 4) = "jpeg" Then ws.Cells(iRow, 1).EntireRow.Delete
Next
For iRow = 2 To iLastRow
sPictureName = ws.Cells(iRow, 1) ' A
sChipCoX = ws.Cells(iRow, 4) ' D
sChipCoY = ws.Cells(iRow, 5) ' E
```
Please bear with me. My code is probably complete shit, so I appreciate all feedback! So what this does is, on my main workbook, there are a bunch of UNC hyperlinks in Row M, that link to files in a section drive.
What this code does:
Go down the list of hyperlinks in Column M, opens them up and executes the code inside of the "With WBSsource".
First, it searches for instances of the incorrect filepath (st) inside each of the cells formulas (NOT VALUES), and increments a counter using InStr (t), then after the worksheet has been searched, if the final count (c) is more than 0, meaning the search found at least one incorrect filepath, it will proceed to the next step.
It does a Cells.Replace on a worksheet (ws.) basis (at the FORMULA level)
Cells per worksheet are all done, it should save the workbook and close it before moving onto the next one.
Any links that could not be opened will appear in a final popup.
It is by Step 3 that it starts to run sluggish and crash.
I'm trying my best to get this automated and saving the workbooks. Then, once they're all updated, running this code again would be much faster cause it won't have to replace everything again.
Sub List_UpdateAndSave()
Dim lr As Long
Dim i As Integer
Dim WBSsource As Workbook
Dim FileNames As Variant
Dim msg As String
Dim ws As Worksheet
Dim r As Range, t As Long, c As Integer
' Update the individual credit models
With ThisWorkbook.ActiveSheet
lr = .Cells(.Rows.Count, "M").End(xlUp).Row
FileNames = .Range("M2:M" & lr).Value
End With
For i = LBound(FileNames, 1) To UBound(FileNames, 1)
On Error Resume Next
If FileNames(i, 1) Like "*.xls*" Then
Set WBSsource = Workbooks.Open(FileNames(i, 1), _
ReadOnly:=False, _
Password:="", _
UpdateLinks:=3)
If Err = 0 Then
With WBSsource
Application.DisplayAlerts = False
ActiveWorkbook.Final = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
st = "\\corp\Accounts\" 'Search Phrase
n = "\\corp\StackOverflow\Accounts\" 'New Phrase
c = 0
For Each ws In WBSsource.Worksheets
ws.Activate
t = 0
On Error Resume Next
For Each r In ws.Cells.SpecialCells(xlCellTypeFormulas)
t = InStr(1, r.Formula, st)
If t > 0 Then
c = c + 1
End If
Next r
Next ws
If c > 0 Then
'MsgBox ws.Name & Chr(10) & (c)
ws.Cells.Replace st, n
End If
.UpdateLink Name:=ActiveWorkbook.LinkSources, Type:=xlExcelLinks
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
.Save
.Close True
End With
Else
msg = msg & FileNames(i, 1) & Chr(10) & Chr(10)
On Error GoTo 0
End If
End If
Set WBSsource = Nothing
Next i
If Len(msg) > 0 Then
'MsgBox "The Following Files Could Not Be Opened" & _
' Chr(10) & msg, 48, "Error"
Set objShell = CreateObject("Wscript.Shell")
objShell.Popup "The Following Files Could Not Be Opened" & _
Chr(10) & Chr(10) & msg, 48, "Error"
End If
Application.DisplayAlerts = True
End Sub
It's not completely crap. I just learned that we could create an array with this.
FileNames = .Range("M2:M" & lr).Value
It may crash since there's no range limit on the 3rd step. Try getting the last row and column on each worksheet, then create a range based on that.
With ws
' Get end cells
With .Cells.SpecialCells(xlCellTypeLastCell)
intLastRow = .Row
intLastCol = .Column
End With
For each r in .Range(.Cells(1,1), .Cells(intLastRow, intLastCol))
' Check formula if it contains specific string
t = InStr(1, r.Formula, st)
If t > 0 Then
c = c + 1
End If
' Replace formula with new string
r.Formula = Replace(r.Formula, st, n)
Next r
End With
Edit: Here's the full code. Let me know if this works for you.
Option Explicit
' Update the individual credit models
Sub List_UpdateAndSave()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
On Error GoTo ErrorHandler
' Declaration
Dim i As Long
Dim arrLinks As Variant
Dim strLinksErr As String
' Initialization
Dim strPathCur As String: strPathCur = "\\corp\Accounts\" ' search phrase
Dim strPathNew As String: strPathNew = "\\corp\StackOverflow\Accounts\" ' new phrase
With ThisWorkbook.ActiveSheet
' Get links from sheet
arrLinks = .Range("M2:M" & .Cells.SpecialCells(xlCellTypeLastCell).Row).Value
End With
For i = LBound(arrLinks, 1) To UBound(arrLinks, 1)
' Check for Excel links
If VBA.InStr(1, arrLinks(i, 1), ".xls", vbTextCompare) > 0 Then
FnExcelUpdateLinks arrLinks(i, 1), strPathCur, strPathNew
Else
' Add to list of links that could not be opened
strLinksErr = strLinksErr & arrLinks(i, 1) & Chr(10)
End If
Next i
ErrorHandler:
' Display any errors
If Err.Number <> 0 Then MsgBox Err.Description, vbCritical, "Error " & Err.Number
' Display any non-Excel links
If strLinksErr <> "" Then
MsgBox "The following files could not be opened:" & _
Chr(10) & strLinksErr, 48, "Error"
End If
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Function FnExcelUpdateLinks(ByVal strWbkPath As String, ByRef strPathCur As String, ByRef strPathNew As String)
Dim intLastRow As Long, intLastCol As Long
Dim wbkTmp As Workbook
Dim shtTmp As Worksheet
Dim rngCell As Range
' Open link as workbook
Set wbkTmp = Workbooks.Open(strWbkPath, ReadOnly:=False, Password:="", UpdateLinks:=3)
With wbkTmp
For Each shtTmp In .Worksheets
With shtTmp
' Get end cells
With .Cells.SpecialCells(xlCellTypeLastCell)
intLastRow = .Row
intLastCol = .Column
End With
For Each rngCell In .Range(.Cells(1, 1), .Cells(intLastRow, intLastCol))
If VBA.InStr(1, rngCell.Formula, strPathCur) > 0 Then
rngCell.Formula = Replace(rngCell.Formula, strPathCur, strPathNew)
End If
Next rngCell
End With
Next shtTmp
.UpdateLink Name:=.LinkSources, Type:=xlExcelLinks
.Save
.Close True
End With
End Function
The following code opens selected files, one at a time; if a file contains specific text string in B11 (there are four variation: LS2A, LS1PRA, LS1A and LSM12), specified data from Sheet(1) of each file is copied into an array. The search is performed by function “SearchFor” that is called in the main routine.
The array ArrCopy is filled with data from each file and should output into one of the four sheets in Master Workbook(SABI, SABII,LSM or LPRI&II). The output sheet is determined by the text string in B11 of each file.
I can’t get data to output to Master workbook for some reason. I've tried Debug.Print each array item after it's filled and I can see that the array is filled with correct data but I can't get the values to tranfer to the master workbook. The code runs but nothing is outputed on the worksheet.
Please suggest how to make this work. Thanks
Option Explicit
Function SearchFor(output As Worksheet)
Dim rowsCount As Long
Dim NCBead1 As Long, NCBead2 As Long, PCBead1 As Long, PCBead2 As Long
Dim IniString As String, IniVar As String
Dim rngCell As Range, rngCell2 As Range
Dim ArrCopy(1 To 9) As Variant
Dim LastRow As Long
Dim aCell As Range
LastRow = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
'extract initial after last underscore
IniString = ActiveWorkbook.Sheets(1).Range("B6").Value
IniVar = Right(IniString, Len(IniString) - InStrRev(IniString, "_", , 1))
Debug.Print IniVar
'Debug.Print "LastRow = " & LastRow
Set aCell = ActiveSheet.Range("B1:B" & LastRow).Find(What:="Trimmed Mean", LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'Debug.Print "Trimmed Mean can be found in Row # " & aCell.Row
'wb.Sheets(1).Select
For Each rngCell In ActiveSheet.Range("B" & aCell.Row & ":B" & LastRow)
If InStr(rngCell, "NC") > 0 Then
Debug.Print rngCell.Row
NCBead1 = rngCell.Offset(0, 1).Value
NCBead2 = rngCell.Offset(0, 2).Value
'End If
Exit For
End If
Next rngCell
For Each rngCell2 In ActiveSheet.Range("B" & aCell.Row & ":B" & LastRow)
If InStr(rngCell2, "PC") > 0 Then
Debug.Print rngCell2.Row
PCBead1 = rngCell2.Offset(0, 1).Value
PCBead2 = rngCell2.Offset(0, 2).Value
'End If
Exit For
End If
Next rngCell2
'Next searched
Debug.Print NCBead2
ArrCopy(1) = ActiveSheet.Range("B3").Value
ArrCopy(2) = IniVar
ArrCopy(3) = NCBead1
ArrCopy(4) = NCBead2
ArrCopy(5) = PCBead1
ArrCopy(6) = PCBead2
ArrCopy(7) = ActiveSheet.Range("B6").Value
ArrCopy(8) = NCBead1
ArrCopy(9) = NCBead1
' one row spanning several columns
Debug.Print "ArrCopy" & ArrCopy(1)
Debug.Print "ArrCopy" & ArrCopy(2)
Debug.Print "ArrCopy" & ArrCopy(3)
Dim Destination As Range
Set Destination = output.Range("A" & output.Range("A" & Rows.Count).End(xlUp).Row + 1)
Set Destination = Destination.Resize(1, UBound(ArrCopy))
Destination.Value = ArrCopy
End Function
Sub openselectedfiles()
Dim SaveDriveDir As String, MyPath As String, FnameInLoop As String
Dim mybook As Workbook, thisWb As Workbook
Dim N As Long, LstUnderSc As Long, ExtPer As Long, Varin As Long
Dim Fname As Variant, ArrCopy(1 To 9) As Variant
Dim output As Worksheet
Dim inLS2A As Boolean, inLS1PRA As Boolean, inLS1A As Boolean, inLSM12 As Boolean
Set thisWb = ThisWorkbook
' Save the current directory.
SaveDriveDir = CurDir
' Set the path to the folder that you want to open.
MyPath = Application.DefaultFilePath
' Change drive/directory to MyPath.
ChDrive MyPath
ChDir MyPath
' Open GetOpenFilename with the file filters.
Fname = Application.GetOpenFilename( _
FileFilter:="CSV Files (*.csv),*.csv", _
Title:="Select a file or files", _
MultiSelect:=True)
' Perform some action with the files you selected.
If IsArray(Fname) Then
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
For N = LBound(Fname) To UBound(Fname)
' Get only the file name and test to see if it is open.
FnameInLoop = Right(Fname(N), Len(Fname(N)) - InStrRev(Fname(N), Application.PathSeparator, , 1))
If bIsBookOpen(FnameInLoop) = False Then
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(Fname(N))
On Error GoTo 0
If Not mybook Is Nothing Then
mybook.Sheets(1).Select
With ActiveSheet.Range("B11")
inLS2A = InStr(1, .Value, "LS2A", 1) > 0
inLS1PRA = InStr(1, .Value, "LS1PRA", 1) > 0
inLS1A = InStr(1, .Value, "LS1A", 1) > 0
inLSM12 = InStr(1, .Value, "LSM12", 1) > 0
End With
If inLS2A Then
Set output = thisWb.Sheets("SABII")
SearchFor output
ElseIf inLS1PRA Then
Set output = thisWb.Sheets("LPRI&II")
SearchFor output
ElseIf inLS1A Then
Set output = thisWb.Sheets("sabI")
SearchFor output
ElseIf inLSM12 Then
Set output = thisWb.Sheets("LSM")
SearchFor output
End If
'End If
mybook.Close SaveChanges:=False
Set mybook = Nothing
End If
Else
MsgBox "We skipped this file : " & Fname(N) & " because it is already open."
End If
Next N
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
' Change drive/directory back to SaveDriveDir.
ChDrive SaveDriveDir
ChDir SaveDriveDir
End Sub
Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Contributed by Rob Bovey
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function