I've been trying to work on an excel sheet that will compile multiple DXDiag files stored in a folder and create a summary page based on some of the information in each of the DXDiag files. All DxDiag files are named as such:
[Asset Tag] - [Desk Number] - [Employee Name] (some DXDiag filenames has supplemental tags)
Example:
123456 - Q.123-A - John Smith - ABC.txt
There's a button to run the code and import the .txt files. The files appear to load without problem, but then Excel seems to calculate for a while and then freeze.
The expected result is that the files are imported, using the Asset Tag and Desk Number as sheet names. Each sheet is a separate file. The sheet names are then compiled onto a separate sheet named "Worksheet'. The sheet names are then split into Asset Tag and Desk Number, each to their own column (Starting at A2 and B2 respectively).
Worksheet Col C and beyond have Headers like 'Machine Name' (without the quotes), and the rows below have a formula similar to this one: (I would rather have do this via VBA code as well, but formula was simpler for the time being)
=IFERROR(INDIRECT("'"&$A2&TEXT(" - ",1)&$B2&"'!B"&MATCH(C$1,INDIRECT("'"&$A2&TEXT(" - ",1)&$B2&"'!$A:$A"),0)),"")
Which is supposed to look at each sheet, find the text in the header and then return the value in the column next to it. Populating the Worksheet with a list of each machine's Asset Tag, Desk Number, Machine Name, OS, CPU, etc.
Once the sheet is completely populated with data from each of the DXDiags, the information is then copied over to a summary page, the worksheet is cleared and the DXDiag sheets are deleted.
Public xWb As Workbook
Public xToBook As Workbook
Public xStrPath As String
Public xFileDialog As FileDialog
Public xFile As String
Public xFiles As New Collection
Public i As Long
Public tmpArray() As String
Sub update()
Application.ScreenUpdating = True
DoEvents
End Sub
Sub ImportDXDiag()
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a FOLDER containing DXDiags"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
If xFile = "" Then
MsgBox "No files found", vbInformation, "Excel"
Exit Sub
End If
Do While xFile <> ""
FileCount = FileCount + 1
xFiles.Add xFile, xFile
xFile = Dir()
Loop
Set xToBook = ThisWorkbook
If xFiles.Count > 0 Then
For i = 1 To xFiles.Count
Set xWb = Workbooks.Open(xStrPath & xFiles.Item(i))
xWb.Worksheets(1).Copy After:=xToBook.Sheets(xToBook.Sheets.Count)
Application.StatusBar = "Progress: " & i & " of " & FileCount & ": " & Format(i / FileCount, "0%")
Dim objRange1 As Range
Set objRange1 = Range("A1:A112")
objRange1.TextToColumns _
Destination:=Range("A1"), _
DataType:=xlDelimited, _
Tab:=False, _
Semicolon:=False, _
Comma:=False, _
Space:=False, _
Other:=True, _
OtherChar:=":"
' Remove all Leading spaces from DXDiags bewteen A3 and A102
Dim cCell As Range
For Each cCell In Range("A1:A112").Cells
cCell.Value = Trim(cCell.Value)
Next cCell
On Error Resume Next
tmpArray = Split(xWb.Name, " - ")
ActiveSheet.Name = tmpArray(0) & " - " & tmpArray(1)
On Error GoTo 0
xWb.Close False
Next
End If
Call SheetNames
End Sub
Sub SheetNames()
Sheets("Worksheet").Visible = True
Worksheets("Worksheet").Activate
For i = 1 To Sheets.Count
Cells(i, 1) = Sheets(i).Name
Next i
Call ClearTabs
End Sub
Sub ClearTabs()
Sheets("Worksheet").Select
Rows("2:2").Select
Selection.Delete Shift:=xlUp
Rows("2999:2999").Select
Selection.Copy
Rows("3000:3000").Select
ActiveSheet.Paste
Set ws = ThisWorkbook.Sheets("Worksheet")
With ws
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To LastRow
If InStr(1, .Range("A" & i).Value, " - ") Then
tmpArray = Split(.Range("A" & i).Value, " - ")
.Range("A" & i).Value = tmpArray(0)
.Range("B" & i).Value = tmpArray(1)
End If
Next i
End With
Cells.Select
Selection.Copy
Range("A1").Select
Sheets("Summary").Select
Cells.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Sheets("Worksheet").Select
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Sheets("Summary").Select
Range("A1").Select
Application.DisplayAlerts = False
For Each ws In Worksheets
If ws.Name <> "Worksheet" And ws.Name <> "Summary" Then ws.Delete
Next
Application.StatusBar = False
Sheets("Worksheet").Visible = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Display More
I realize that the code is probably really messy. I'm no macro expert and parts of the code were modified from examples I found online. I doubt it's very efficient, which is probably one of the reasons why Excel is freezing up when trying to run it.
EDIT: Here is a copy of the workbook that I'm working on.
(Sorry double posted with it before.)