Vba list all excel files in a folder? - excel

I have the following code which is supposed to list all excel files in a folder.
Code:
Sub List()
'On Error GoTo Message
ActiveSheet.DisplayPageBreaks = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
Dim i2 As Long
Dim i3 As Long
Dim j2 As Long
Dim name As String
Dim Txt As String
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(ThisWorkbook.Worksheets(1).Range("M4").value)
i = 18
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.files
'print file path
ThisWorkbook.Worksheets(1).Cells(i, 6) = objFile.path
'print file path
ThisWorkbook.Worksheets(1).Cells(i, 7) = Replace(objFile.name, ".xlsx", "")
'print file removal icon
ThisWorkbook.Worksheets(1).Cells(i, 30) = "Remove"
'Add Hyperlink
ThisWorkbook.Worksheets(1).Hyperlinks.Add Anchor:=Cells(i, 27), Address:=objFile.path, TextToDisplay:="Open Announcement"
'Lookup contact info
ThisWorkbook.Worksheets(1).Cells(i, 11).Formula = "=IFERROR(INDEX(Contacts!$C:$C,MATCH(""*"" & """ & Range("G" & i).value & """ & ""*"",Contacts!$B:$B,0)),IFERROR(INDEX(Contacts!$C:$C,MATCH(""" & Left(Range("G" & i).value, 7) & """ & ""*"",Contacts!$B:$B,0)),""""))"
ThisWorkbook.Worksheets(1).Cells(i, 14).Formula = "=IF(""" & Range("K" & i).value & """ = """","""",IFERROR(INDEX(Contacts!$D:$D,MATCH(""*"" & """ & Range("K" & i).value & """ & ""*"",Contacts!$C:$C,0)),""""))"
ThisWorkbook.Worksheets(1).Cells(i, 18).Formula = "=IF(""" & Range("K" & i).value & """ = """","""",IFERROR(INDEX(Contacts!$E:$E,MATCH(""*"" & """ & Range("K" & i).value & """ & ""*"",Contacts!$C:$C,0)),""""))"
ThisWorkbook.Worksheets(1).Cells(i, 23) = "=IF(K" & i & "="""",""Missing Contact! "","""")&IF(INDEX(Data!L:L,MATCH(G" & i & ",Data!F:F,0))=""TBC"",""Missing Data! "","""")&IF(U" & i & ">=DATE(2017,1,1),"""",""Check Date!"")"
'Delivery Dates
ThisWorkbook.Worksheets(1).Cells(i, 21).Formula = "=IFERROR(INDEX(Data!$Q:$Q,MATCH(""*"" & """ & Range("G" & i).value & """ & ""*"",Data!$F:$F,0)),IFERROR(INDEX(Data!$Q:$Q,MATCH(""*"" & """ & Left(Range("G" & i).value, 7) & """ & ""*"",Data!$F:$F,0)),""""))"
ThisWorkbook.Worksheets(1).Cells(i, 25) = "Sync"
i = i + 1
Next objFile
ThisWorkbook.Worksheets(1).Calculate
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit Sub
Message:
Application.DisplayAlerts = False
Exit Sub
End Sub
For some reason, despite there being several excel files in the folder, only one file is being listed.
Please can someone show me where i am going wrong?

Start with something simple and then make it more and more complicated. The following works for me, displaying all the files you have in the folder. They are printed in the immediate window (Ctrl+G) in the Visual Basic Editor. From there, you can go further:
Option Explicit
Sub List()
On Error GoTo Message
ActiveSheet.DisplayPageBreaks = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Long
Dim i2 As Long
Dim i3 As Long
Dim j2 As Long
Dim name As String
Dim Txt As String
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("C:\Users\TestMe\Arch")
For Each objFile In objFolder.Files
Debug.Print objFile
Next objFile
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit Sub
Message:
Application.DisplayAlerts = False
Exit Sub
End Sub

Related

Error code 76 with VBA, not in every moment

I'm having an issue with my code:
Sub lalalala ()
Dim s5 As Worksheet
Set s5 = ThisWorkbook.Sheets("Test")
Dim DesktopPath As String
Dim DesktopPathMAIN As String
Dim DesktopPathSUB As String
Dim file As String
Dim sfile As String
Dim sDFolder As String
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
DesktopPath = Environ("USERPROFILE") & "\Desktop\"
DesktopPathMAIN = DesktopPath & "THE FINAL TEST"
If Dir(DesktopPathMAIN, vbDirectory) = "" Then
Shell ("cmd /c mkdir """ & DesktopPathMAIN & """")
End If
lastrow = s5.Range("B" & s5.Rows.Count).End(xlUp).Row
Set rng = s5.Range("B1:B" & lastrow)
For Each c In rng
If Dir(DesktopPathMAIN & "\" & c.Offset(, 5).Value, vbDirectory) = "" Then
Shell ("cmd /c mkdir """ & DesktopPathMAIN & "\" & c.Offset(, 5).Value & """")
End If
Next c
lastrow = s5.Range("G" & s5.Rows.Count).End(xlUp).Row
Set rng = s5.Range("G1:G" & lastrow)
For Each c In rng
sDFolder = DesktopPathMAIN & "\" & c.Value & "\"
sfile = s5.Range("H1").Value & c.Offset(, -2).Value
Call oFSO.CopyFile(sfile, sDFolder)
Next c
End Sub
When i run the macro it causes error code 76, but if i run again it works perfectly. I realized it happens when the cell changes the value of the destination folder at this line sfile = s5.Range("H1").Value & c.Offset(, -2).Value.
But it only happens 1 time, if i run again it works perfectly.
How can i fix that?
thank you

Sort items per customer

I am making a tool in excel VBA to bulk create some kind of invoices to each customer. We are making LIVE streams and selling kids clothing, then we write all our orders to excel sheet. Example:
orders list
Then we have to sort all those orders by customer (there are many of them) and create some kind of invoice for each customer. Example: "invoice template"
I use this code to bulk create those and download as pdfs.
Sub Create_PDF_Files()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim dsh As Worksheet
Dim tsh As Worksheet
Dim setting_Sh As Worksheet
Set dsh = ThisWorkbook.Sheets("uzsakymai")
Set tsh = ThisWorkbook.Sheets("lapukas")
Set setting_Sh = ThisWorkbook.Sheets("Settings")
Application.DisplayStatusBar = True
Application.StatusBar = ""
Dim i As Integer
Dim File_Name As String
For i = 2 To dsh.Range("A" & Application.Rows.Count).End(xlUp).Row
Application.StatusBar = i - 1 & "/" & dsh.Range("A" & Application.Rows.Count).End(xlUp).Row - 1
tsh.Range("D1").Value = dsh.Range("C" & i).Value
tsh.Range("A4").Value = dsh.Range("B" & i).Value
tsh.Range("B4").Value = dsh.Range("A" & i).Value & " - " & dsh.Range("E" & i).Value
tsh.Range("P4").Value = dsh.Range("D" & i).Value
File_Name = dsh.Range("A" & i).Value & "(" & dsh.Range("C" & i).Value & "-" & dsh.Range("D" & i).Value & ").pdf"
tsh.ExportAsFixedFormat xlTypePDF, setting_Sh.Range("F4").Value & "\" & File_Name
Next i
Application.StatusBar = ""
MsgBox "Done"
End Sub
But what it does is creating invoice for each item.
EXAMPLE
Any ideas how could I make it work for me as I want it to work?
---EDIT---
After ALeXceL answer, it seems to have some bugs. I changed my code to his code, and I see some progress in creating this program, but what it does, is it shows first item correctly, but all the other items are appearing starting on A24 cell. EXAMPLE
---EDIT---
IT WORKS!!!
Assuming that "uzsakymai" is "orders", the 'data sheet' (dsh) and "lapukas" is the 'template' sheet (tsh), I did these changes, added some counters, in order to the logic flows the right way:
Important: before put this code to run you MUST classify the 'orders' table (dsh, or "uzsakymai") first by Name, then, by Size (as you wish, according to the images posted)
Option Explicit
Sub Create_PDF_Files()
Dim Orders_sh As Worksheet
Dim Template_sh As Worksheet
Dim setting_Sh As Worksheet
Dim oCell As Excel.Range
Dim strKey_TheName As String
Dim lngTemplate_A As Long
Dim lngSumOfItems As Long
Dim dblSumOfValues As Double
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set Orders_sh = ThisWorkbook.Sheets("uzsakymai")
Set Template_sh = ThisWorkbook.Sheets("lapukas")
Set setting_Sh = ThisWorkbook.Sheets("Settings")
Application.DisplayStatusBar = True
Application.StatusBar = ""
Dim lngI As Long
Dim File_Name As String
'At this point, the Orders_sh worksheet should already have its fields properly sorted/ordered. (Name, then Size)
lngI = 2
Application.StatusBar = lngI - 1 & "/" & Orders_sh.Range("A11").End(xlUp).Row - 1 'a maximum of 10 items can be written here!
Set oCell = Orders_sh.Range("A" & lngI) ' the initial cell
Do
strKey_TheName = UCase(Orders_sh.Range("C" & lngI).Value)
lngSumOfItems = 0
dblSumOfValues = 0
Do
Template_sh.Range("D1").Value = Orders_sh.Range("C" & lngI).Value
lngTemplate_A = IIf(lngSumOfItems = 0, 4, Template_sh.Range("A10").End(xlUp).Offset(1, 0).Row)
Template_sh.Range("A" & lngTemplate_A).Value = Orders_sh.Range("B" & lngI).Value
Template_sh.Range("B" & lngTemplate_A).Value = Orders_sh.Range("A" & lngI).Value & " - " & Orders_sh.Range("E" & lngI).Value
Template_sh.Range("P" & lngTemplate_A).Value = Orders_sh.Range("D" & lngI).Value
lngSumOfItems = lngSumOfItems + 1
dblSumOfValues = dblSumOfValues + Orders_sh.Range("D" & lngI).Value
File_Name = lngSumOfItems & "(" & Orders_sh.Range("C" & lngI).Value & "-" & VBA.Round(dblSumOfValues, 0) & ").pdf"
lngI = lngI + 1
Set oCell = oCell.Offset(1, 0)
Loop Until strKey_TheName <> UCase(oCell.Offset(0, 2).Value)
Template_sh.ExportAsFixedFormat xlTypePDF, setting_Sh.Range("F4").Value & "\" & File_Name
Template_sh.Range("D1").Value = ""
Template_sh.Range("A4:P10").ClearContents
Loop Until Len(oCell.Value) = 0
Application.StatusBar = ""
MsgBox "Done"
End Sub

Extract comments from multiple word docs into Excel

I'm trying to loop through all word documents in a folder and put all the comments for each file into an Excel workbook.
When I run my code I get the following error "Run-time error '91' Object variable or With block Variable not set.
The code only gets comments from the first file in the directory, then errors, it's not looping.
I've looked at numerous websites and found plenty of references for extracting comments into excel, but not for all word files in a directory.
https://answers.microsoft.com/en-us/msoffice/forum/all/export-word-review-comments-in-excel/54818c46-b7d2-416c-a4e3-3131ab68809c
https://www.mrexcel.com/board/threads/extracting-comments-from-word-document-to-excel.1126759/
This website looked promising for what I need to do, but no one answered his question
Extracting data from multiple word docs to single excel
I updated the code to open each word file, but I get the following error: Run-time error '5': Invalid procedure call or argument
It appears to open each word document but doesn't populate the excel sheet with the comments.
UPDATED CODE:
'VBA List all files in a folder using Dir
Private Sub LoopThroughWordFiles()
'Variable Declaration
Dim sFilePath As String
Dim sFileName As String
Dim i As Integer, HeadingRow As Integer
Dim objPara As Paragraph
Dim objComment As Comment
Dim strSection As String
Dim strTemp
Dim myRange As Range
'Specify File Path
sFilePath = "C:\CommentTest"
'Check for back slash
If Right(sFilePath, 1) <> "\" Then
sFilePath = sFilePath & "\"
End If
'Create an object for Excel.
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
'Create a workbook
Set xlWB = xlApp.Workbooks.Add
'Create Excel worksheet
With xlWB.Worksheets(1)
' Create Heading
HeadingRow = 1
.Cells(HeadingRow, 1).Formula = "File Name"
.Cells(HeadingRow, 2).Formula = "Comment"
.Cells(HeadingRow, 3).Formula = "Page"
.Cells(HeadingRow, 4).Formula = "Paragraph"
.Cells(HeadingRow, 5).Formula = "Comment"
.Cells(HeadingRow, 6).Formula = "Reviewer"
.Cells(HeadingRow, 7).Formula = "Date"
strSection = "preamble" 'all sections before "1." will be labeled as "preamble"
strTemp = "preamble"
xlRow = 1
sFileName = Dir(sFilePath)
MsgBox ("sFileName: " + sFileName)
MsgBox ("sFilePath: " + sFilePath)
vFile = Dir(sFilePath & "*.*")
Do While sFileName <> ""
Set oDoc = Documents.Open(Filename:=sFilePath & vFile)
For i = 1 To ActiveDocument.Comments.count
Set myRange = ActiveDocument.Comments(i).Scope
strSection = ParentLevel(myRange.Paragraphs(1)) ' find the section heading for this comment
'MsgBox strSection
.Cells(i + HeadingRow, 1).Formula = ActiveDocument.Comments(i).Index
.Cells(i + HeadingRow, 2).Formula = ActiveDocument.Comments(i).Reference.Information(wdActiveEndAdjustedPageNumber)
.Cells(i + HeadingRow, 3).Value = strSection
.Cells(i + HeadingRow, 4).Formula = ActiveDocument.Comments(i).Range
.Cells(i + HeadingRow, 5).Formula = ActiveDocument.Comments(i).Initial
.Cells(i + HeadingRow, 6).Formula = Format(ActiveDocument.Comments(i).Date, "MM/dd/yyyy")
.Cells(i + HeadingRow, 7).Formula = ActiveDocument.Comments(i).Range.ListFormat.ListString
Next i
'- CLOSE WORD DOCUMENT
oDoc.Close SaveChanges:=False
vFile = Dir
'Set the fileName to the next available file
sFileName = Dir
Loop
End With
Set xlApp = Nothing
Set xlApp = CreateObject("Excel.Application")
End Sub
Function ParentLevel(Para As Word.Paragraph) As String
'From Tony Jollans
' Finds the first outlined numbered paragraph above the given paragraph object
Dim sStyle As Variant
Dim strTitle As String
Dim ParaAbove As Word.Paragraph
Set ParaAbove = Para
sStyle = Para.Range.ParagraphStyle
sStyle = Left(sStyle, 4)
If sStyle = "Head" Then
GoTo Skip
End If
Do While ParaAbove.OutlineLevel = Para.OutlineLevel
Set ParaAbove = ParaAbove.Previous
Loop
Skip:
strTitle = ParaAbove.Range.Text
strTitle = Left(strTitle, Len(strTitle) - 1)
ParentLevel = ParaAbove.Range.ListFormat.ListString & " " & strTitle
End Function
This version of the Excel macro outputs all the document comments to the active worksheet(starting at row 1), with the filenames in column A.
Sub ImportComments()
'Note: this code requires a reference to the Word object model.
'See under the VBE's Tools|References.
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, StrCmt As String, StrTmp As String, i As Long, j As Long
StrCmt = Replace("File,Page,Author,Date & Time,H.Lvl,Commented Text,Comment,Reviewer,Resolution,Date Resolved,Edit Doc,Edit By,Edit Date", ",", vbTab)
strFolder = GetFolder: If strFolder = "" Then Exit Sub
Dim wdApp As New Word.Application, wdDoc As Word.Document
wdApp.DisplayAlerts = False: wdApp.WordBasic.DisableAutoMacros
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With wdDoc
If .Comments.Count > 0 Then
' Process the Comments
For i = 1 To .Comments.Count
StrCmt = StrCmt & vbCr & Split(strFolder, ".doc")(0) & vbTab
With .Comments(i)
StrCmt = StrCmt & .Reference.Information(wdActiveEndAdjustedPageNumber) & _
vbTab & .Author & vbTab & .Date & vbTab
With .Scope.Paragraphs(1).Range
StrCmt = StrCmt & _
.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel").Paragraphs.First.Range.ListFormat.ListString & vbTab
With .Duplicate
.End = .End - 1
StrCmt = StrCmt & Replace(Replace(.Text, vbTab, "<TAB>"), vbCr, "<P>") & vbTab
End With
End With
With .Range.Duplicate
.End = .End - 1
StrCmt = StrCmt & Replace(Replace(.Text, vbTab, "<TAB>"), vbCr, "<P>")
End With
End With
Next
' Update the worksheet
With ActiveSheet
.Columns("E").NumberFormat = "#"
For i = 0 To UBound(Split(StrCmt, vbCr))
StrTmp = Split(StrCmt, vbCr)(i)
For j = 0 To UBound(Split(StrTmp, vbTab))
.Cells(i + 1, j + 1).Value = Split(StrTmp, vbTab)(j)
Next
Next
.Columns("A:M").AutoFit: .Columns("D:E").ColumnWidth = 25
End With
End If
.Close SaveChanges:=False
End With
strFile = Dir()
Wend
wdApp.Quit
' Tell the user we're done.
MsgBox "Finished.", vbOKOnly
' Release object memory
Set wdDoc = Nothing: Set wdApp = Nothing
Application.ScreenUpdating = True
End Sub
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
Try the following Excel macro. It loops through all Word documents in the selected folder, adding the comments from each commented document to new worksheets in the active workbook.
Sub ImportComments()
'Note: this code requires a reference to the Word object model.
'See under the VBE's Tools|References.
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, StrCmt As String, StrTmp As String, i As Long, j As Long
strFolder = GetFolder: If strFolder = "" Then Exit Sub
Dim wdApp As New Word.Application, wdDoc As Word.Document, xlWkSht As Worksheet
wdApp.DisplayAlerts = False: wdApp.WordBasic.DisableAutoMacros
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With wdDoc
If .Comments.Count > 0 Then
StrCmt = Replace("Page,Author,Date & Time,H.Lvl,Commented Text,Comment,Reviewer,Resolution,Date Resolved,Edit Doc,Edit By,Edit Date", ",", vbTab)
' Process the Comments
For i = 1 To .Comments.Count
With .Comments(i)
StrCmt = StrCmt & vbCr & .Reference.Information(wdActiveEndAdjustedPageNumber) & _
vbTab & .Author & vbTab & .Date & vbTab
With .Scope.Paragraphs(1).Range
StrCmt = StrCmt & _
.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel").Paragraphs.First.Range.ListFormat.ListString & vbTab
With .Duplicate
.End = .End - 1
StrCmt = StrCmt & Replace(Replace(.Text, vbTab, "<TAB>"), vbCr, "<P>") & vbTab
End With
End With
With .Range.Duplicate
.End = .End - 1
StrCmt = StrCmt & Replace(Replace(.Text, vbTab, "<TAB>"), vbCr, "<P>")
End With
End With
Next
'Add a new worksheet
Set xlWkSht = .Worksheet.Add
' Update the worksheet
With xlWkSht
.Name = Split(strFile, ".doc")(0)
.Columns("D").NumberFormat = "#"
For i = 0 To UBound(Split(StrCmt, vbCr))
StrTmp = Split(StrCmt, vbCr)(i)
For j = 0 To UBound(Split(StrTmp, vbTab))
.Cells(i + 1, j + 1).Value = Split(StrTmp, vbTab)(j)
Next
Next
.Columns("A:L").AutoFit: .Columns("E:F").ColumnWidth = 25
End With
End If
.Close SaveChanges:=False
End With
strFile = Dir()
Wend
wdApp.Quit
' Tell the user we're done.
MsgBox "Finished.", vbOKOnly
' Release object memory
Set wdDoc = Nothing: Set wdApp = Nothing: Set xlWkSht = Nothing
Application.ScreenUpdating = True
End Sub
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

I want to replace a number with a variable that is linked with a Cell input, but i get an error

I already posted the question with only particles of my code. I want to replace the 0.5 in the following formula with my double variable z.
.Cells(21, 6).Formula = "=AVERAGEIF(RC[-4]:R[" & Total & "]C[-4],"">""&0.5*MAX(RC[-4]:R[" & Total & "]C[-4]))"
My whole code looks like this:
Sub ImportMultipleTextFile()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim InputTextFile As Variant
Dim SourceDataFolder As String
Dim OutputDataFolder As String
Dim wb As Workbook: Set wb = ThisWorkbook
Dim LastRow As Integer
Dim MyFolder As String
Dim x As Integer
Dim Total As Long
x = 3
Dim Dateiname As String
Dim z As Double
z = Worksheets(1).Range("O1").Value
If MsgBox("Kistler Drehdaten?", vbYesNo) = vbYes Then
MsgBox "Wähle den Kistler Ordner aus mit den .txt Dateien"
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
MyFolder = .SelectedItems(1)
Err.Clear
End With
SourceDataFolder = MyFolder
'Loop through each text file in source folder
InputTextFile = Dir(SourceDataFolder & "\*.txt")
While InputTextFile <> ""
Workbooks.OpenText Filename:=SourceDataFolder & "\" & InputTextFile, DataType:=xlDelimited, Tab:=True
Dateiname = ActiveWorkbook.Name
Range("A:E").Copy
wb.Worksheets(1).Range("A:E").PasteSpecial
Total = wb.Worksheets(1).Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count
Dim avgSourceRangePart As String
avgSourceRangePart = "RC[-4]:R[" & Total & "]C[-4]"
Dim maxPart As String
maxPart = "MAX(RC[-4]:R[" & Total & "]C[-4])"
Dim avgConditionPart As String
avgConditionPart = """>"" & " & z & " * " & maxPart & ")"
With wb.Worksheets(1)
.Cells(21, 6).Formula = "=AVERAGEIF(RC[-4]:R[" & Total & "]C[-4],"">""&0.5*MAX(RC[-4]:R[" & Total & "]C[-4]))"
'.Cells(21, 7).Formula = "=AVERAGEIF(RC[-4]:R[" & Total & "]C[-4],"">"" &" & z & "*MAX(RC[-4]:R[" & Total & "]C[-4]))"
'.Cells(21, 7).Formula = "=AVERAGEIF(RC[-4]:R[" & Total & "]C[-4],"">"" &" & z & "*MAX(RC[-4]:R[" & Total & "]C[-4]))"
.Cells(21, 7).FormulaR1C1 = "=AVERAGEIF(" & avgSourceRangePart & ";" & avgConditionPart & ")"
.Cells(21, 8).Formula = "=AVERAGEIF(RC[-4]:R[" & Total & "]C[-4],"">""&0.5*MAX(RC[-4]:R[" & Total & "]C[-4]))"
.Range("F21:H21").Copy
End With
x = x + 1
Range("A:I").Clear
'Close the opened input file
Workbooks(InputTextFile).Close
InputTextFile = Dir
Wend
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End If
End Sub
....followed by another elseif with the same style for different text packages that need to be opened.
Continuing from my previous answer -
The line you're looking for is:
"=AVERAGEIF(RC[-4]:R[" & Total & "]C[-4],"">"" &" & z & "*MAX(RC[-4]:R[" & Total & "]C[-4]))"
But there are other problems with the code that cause errors.
The main problem was with Range("A:E").Copy. The range was not qualified, meaning it was referring to the wrong book. See the corrected code below:
Sub ImportMultipleTextFile()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim InputTextFile As Variant
Dim SourceDataFolder As String
Dim OutputDataFolder As String
Dim wb As Workbook: Set wb = ThisWorkbook
Dim LastRow As Integer
Dim MyFolder As String
Dim x As Integer: x = 3
Dim Total As Long
Dim TxtFile As Workbook
Dim z As Double
z = Worksheets(1).Range("O1").Value
If MsgBox("Kistler Drehdaten?", vbYesNo) = vbYes Then
MsgBox "Wähle den Kistler Ordner aus mit den .txt Dateien"
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
MyFolder = .SelectedItems(1)
Err.Clear
End With
SourceDataFolder = MyFolder
'Loop through each text file in source folder
InputTextFile = Dir(SourceDataFolder & "\*.txt")
While InputTextFile <> ""
Workbooks.OpenText Filename:=SourceDataFolder & "\" & InputTextFile, DataType:=xlDelimited, Tab:=True
Set TxtFile = Application.Workbooks(InputTextFile)
TxtFile.Sheets(1).Range("A:E").Copy
wb.Worksheets(1).Range("A:E").PasteSpecial
Total = wb.Worksheets(1).Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count
With wb.Worksheets(1)
.Cells(21, 6).Formula = "=AVERAGEIF(RC[-4]:R[" & Total & "]C[-4],"">"" &" & z & "*MAX(RC[-4]:R[" & Total & "]C[-4]))"
.Range("F21:H21").Copy
End With
Range("A:I").Clear
'Close the opened input file
TxtFile.Close
InputTextFile = Dir
Wend
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Rename Folder/File located in a server using Excel VBA

I'm writing a Macro which main function is to rename folders in a specific server location (Main folder). All the files on this Main Folder have the 3 first characters as numbers which are in sequential order. Since I'm changing them often I wanted a Macro which was able to rename the folders from a item up (this item would be the first 3 characters of a folders name)
The the issue I have is that since the files are in a server I cannot really change the name, it seams like I just can change the name which appears to the user but not the "real"/first name.
Perhaps with a couple of images it might help:
The code we are using is the following:
Private Sub PrintFolders()
Dim objFSO As Object
Dim objFSO_2 As Object
Dim objFolder As Object
Dim objSubFolder As Object
Dim fileExcel As Object
Dim xpto As Object
Dim objSubSubFile_Excel As Object
Dim auxStringName As String, auxStringPath As String
Dim i As Integer
Application.StatusBar = ""
'Get Folder Path
auxStringPath = Range("C2").Text
If auxStringPath = "" Then
Err = 19
GoTo handleCancel
End If
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(auxStringPath)
i = 0
'Get intBegin
intBegin = CInt(Range("C3").Value)
'loops through each folder in the directory and prints their names and path
On Error GoTo handleCancel
Application.EnableCancelKey = xlErrorHandler
'MsgBox "This may take a long time: press ESC to cancel"
For Each objSubFolder In objFolder.subfolders
Application.StatusBar = objSubFolder.Path & " " & objSubFolder.Name
If CInt(Left(objSubFolder.Name, 3)) >= intBegin Then
If intBegin < 10 Then
auxStringName = "00" & CStr(intBegin + i) & Mid(objSubFolder.Name, 4)
ElseIf intBegin < 100 Then
auxStringName = "0" & CStr(intBegin + i) & Mid(objSubFolder.Name, 4)
Else
auxStringName = CStr(intBegin + i) & Mid(objSubFolder.Name, 4)
End If
For Each fileExcel In objSubFolder.Files
If Right(fileExcel.Name, 4) = "xlsx" Or Right(fileExcel.Name, 4) = "xlsm" Then
Name auxStringPath & "\" & objSubFolder.Name & "\" & fileExcel.Name As auxStringPath & "\" & objSubFolder.Name & "\" & Left(auxStringName, 3) & Mid(fileExcel.Name, 4)
End If
Next fileExcel
Name auxStringPath & "\" & objSubFolder.Name As auxStringPath & "\" & auxStringName
i = i + 1
End If
Next objSubFolder
handleCancel:
If Err = 18 Then
MsgBox "You cancelled"
ElseIf Err = 19 Then
MsgBox "Missing Path"
End If
Set objFSO = Nothing
Set objFolder = Nothing
End Sub
Does anyone can help on this?
Does anzone has alreadz had a similar issue?

Resources