I have this original code of mine that loops through one folder and files inside the folder to copy and paste data out into a new worksheet using .find and then i trim the data using .find,split,Right,Left function to remove any unwanted extra letters so that it would look neater , and if a certain string wasn't found, i will have to search for another string again to make sure all columns are filled with data. However too many .find makes the runtime extremely long. I have provided the code below after my original coding, please take a look and let me know how can i implement it and reduce runtime, other suggestions are welcomed too!
Some of the strings that i search using .find may seem like an typo, please don't mind it, its just an example.
Option Explicit
Sub GenerateData()
Application.ScreenUpdating = False
Dim wks As Worksheet
Dim wkb As Workbook
Set wkb = ActiveWorkbook
Set wks = wkb.Worksheets.Add(After:=wkb.Worksheets(wkb.Worksheets.Count), Type:=xlWorksheet)
' Add headers data
With wks
.Range("A1:K1") = Array("Test", "Temp", "Type", "Start", "FileName", "No", "End", _
"Month", "Smart", "Errors", "ErrorCellAddress")
End With
' Early Binding - Add "Microsoft Scripting Runtime" Reference
Dim FSO As New Scripting.FileSystemObject
' Set FolderPath
Dim FolderPath As String
FolderPath = "c:\Users\Desktop\Tryout\"' Set Folder FSO
Dim Folder As Scripting.Folder
Set Folder = FSO.GetFolder(FolderPath)
' Loop thru each file
Dim File As Scripting.File
Dim a As Range, b As Range, c As Range, d As Range, e As Range, f As Range, g As Range, h As Range, l As Range
For Each File In Folder.Files
Dim wkbData As Workbook
Set wkbData = Workbooks.Open(File.Path)
Dim wksData As Worksheet
ActiveSheet.Name = "Control"
Set wksData = wkbData.Worksheets("Control") ' -> Assume this file has only 1 worksheet
'Format of the data
Dim BlankRow As Long
BlankRow = wks.Range("A"& wks.Rows.Count).End(xlUp).Row + 1
' Write filename in col E,F,G
wks.Cells(BlankRow, 5).Value = File.Name
wks.Cells(BlankRow, 6).Value = File.Name
wks.Cells(BlankRow, 7).Value = File.Name
'Find Testtest
Set a = wksData.Columns("A:A").Find(" testtest : ", LookIn:=xlValues)
If Not a Is Nothing Then
wks.Cells(BlankRow, 1).Value = a.Value
End If
'Find Temp
Set b = wksData.Columns("A:A").Find(" testflyy : ", LookIn:=xlValues)
If Not b Is Nothing Then
wks.Cells(BlankRow, 2).Value = b.Value
End If
'Find Type
Set d = wksData.Columns("A:A").Find(" testflyy : ", LookIn:=xlValues)
If Not d Is Nothing Then
wks.Cells(BlankRow, 3).Value = d.Value
End If
'Find start
Set l = wksData.Columns("A:A").Find(" Started at: ", LookIn:=xlValues)
If Not l Is Nothing Then
wks.Cells(BlankRow, 4).Value = l.Value
End If
'Find Smart
Set c = wksData.Columns("A:A").Find("SmartABC ", LookIn:=xlValues)
If Not c Is Nothing Then
wks.Cells(BlankRow, 9).Value = c.Value
Else
Set f = wksData.Columns("A:A").Find("SmarABCD Version ", LookIn:=xlValues)
If Not f Is Nothing Then
wks.Cells(BlankRow, 9).Value = f.Value
Else
Set g = wksData.Columns("A:A").Find("smarabcd_efg revision", LookIn:=xlValues)
If Not g Is Nothing Then
wks.Cells(BlankRow, 9).Value = g.Value
End If
End If
End If
'Find Errors
Set e = wksData.Columns("A:A").Find("ERROR: ABC", LookIn:=xlValues)
If Not e Is Nothing Then
wks.Cells(BlankRow, 10).Value = e.Value
wks.Cells(BlankRow, 11).Value = e.Address
Else
Set h = wksData.Columns("A:A").Find("ERROR: EFG", LookIn:=xlValues)
If Not h Is Nothing Then
wks.Cells(BlankRow, 10).Value = h.Value
End If
End If
' Trim and tidy up Data
'Trim Testtest RowA(1)
wks.Cells(BlankRow, 1).Replace What:="testtest : ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'Trim StartTime RowD(4)
wks.Cells(BlankRow, 4).Replace What:=" Started at: ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'Trim Temp RowB(2)
Dim strSearchB As String, strSearchC As String
Dim bCell As Range, cCell As Range
Dim s2 As String, s3 As String
strSearchB = " testflow : B"
strSearchC = " testflow : M"
Set bCell = wks.Cells(BlankRow, 2).Find(What:=strSearchB, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not bCell Is Nothing Then
s2 = Split(bCell.Value, ":")(1)
s2 = Mid(s2, 1, 3)
bCell.Value = s2
Else
Set cCell = wks.Cells(BlankRow, 2).Find(What:=strSearchC, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not cCell Is Nothing Then
s3 = Split(cCell.Value, ":")(1)
s3 = Mid(s3, 10, 2)
cCell.Value = s3
End If
End If
'Trim Type RowC(3)
Dim strSearchD As String, strSearchE As String
Dim dCell As Range, eCell As Range
Dim s4 As String, s5 As String
strSearchD = " testflow : B"
strSearchE = " testflow : M1947"
Set dCell = wks.Cells(BlankRow, 3).Find(What:=strSearchD, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not dCell Is Nothing Then
s4 = Split(dCell.Value, "_", 3)(2)
s4 = Mid(s4, 1, 3)
dCell.Value = s4
Else
Set eCell = wks.Cells(BlankRow, 3).Find(What:=strSearchE, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not eCell Is Nothing Then
eCell.Value = "123"
End If
End If
'Trim No RowF(6)
Dim strSearchF As String
Dim fCell As Range
Dim s6 As String
strSearchF = "homebeestrash_archivetreser"
Set fCell = wks.Cells(BlankRow, 6).Find(What:=strSearchF, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not fCell Is Nothing Then
s6 = Split(fCell.Value, "treser")(1)
s6 = Mid(s6, 1, 2)
fCell.Value = s6
End If
'Trim EndDate RowG(7)
Dim strSearchG As String
Dim gCell As Range
Dim s7 As String
strSearchG = "homebeestrash_archivetreser"
Set gCell = wks.Cells(BlankRow, 7).Find(What:=strSearchG, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not gCell Is Nothing Then
s7 = Split(gCell.Value, "reports")(1)
s7 = Split(s7, "Report")(0)
s7 = Left(s7, 8) & ""& Right(s7, 6)
'Month Row H(8)
wks.Cells(BlankRow, 8).Value = WorksheetFunction.Transpose(Left(s7, 4) & "-"& Mid(s7, 5, 2) & "-"& Mid(s7, 7, 2))
gCell.Value = s7
End If
wks.Cells(BlankRow, 8).NumberFormat = "[$-en-US]mmmm d, yyyy;@"'Set Date format
'Trim Smart
Dim strSearchST As String
Dim stCell As Range
Dim s8 As String
strSearchST = "This is "
Set stCell = wks.Cells(BlankRow, 9).Find(What:=strSearchST, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not stCell Is Nothing Then
s8 = Split(stCell.Value, "This is ")(1)
s8 = Mid(s8, 1, 29)
stCell.Value = s8
End If
wkbData.Close False
Next File
'Add AutoFilter
Dim StartDate As Long, EndDate As Long
With wks.Cells(BlankRow, 8)
StartDate = DateSerial(Year(.Value), Month(.Value), 1)
EndDate = DateSerial(Year(.Value), Month(.Value) + 1, 0)
End With
wks.Cells(BlankRow, 8).AutoFilter Field:=5, Criteria1:=">="& StartDate, Operator:=xlAnd, Criteria2:="<="& EndDate
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
End Sub
Can anyone let me know how can i use the coding below and alter it to what my original code does. If possible maybe provide me a small part of the code so that i can understand and then continue myself or so that i can modify it myself.
Private Sub AddColumnHeaders(ByVal sheet As Worksheet)
sheet.Range("A1:K1") = Array( _
"Test", "Temp", "Type", "Start", _
"FileName", "No", "End", "Month", _
"Smart", "Errors", "ErrorCellAddress")
End Sub
Dim sheet As Worksheet
Set sheet = CreateOutputSheet(ActiveWorkbook)
Private Function CreateOutputSheet(ByVal book As Workbook) As Worksheet
Dim sheet As Worksheet
Set sheet = book.Worksheets.Add(After:=book.Worksheets(book.Worksheets.Count))
AddColumnHeaders sheet
Set CreateOutputSheet = sheet
End Function
Dim basePath As String
basePath = Environ$("USERPROFILE") & "\Desktop\Tryout\"
Dim baseFolder As Scripting.Folder
With New Scripting.FileSystemObject
Set baseFolder = .GetFolder(basePath)
End With
Dim table As ListObject
Set table = wks.ListObjects("TableName")
Dim newRow As ListRow
Set newRow = table.ListRows.Add
Private Function PopulateIfFound(ByVal source As Range, ByVal value As String, ByVal row As ListRow, ByVal writeToColumn As Long, Optional ByVal writeAddressToNextColumn As Boolean = False) As Boolean
Dim result As Range
Set result = source.Find(value, LookIn:=xlValues)
If Not result Is Nothing Then
Dim cell As Range
Set cell = row.Range.Cells(ColumnIndex:=writeToColumn)
cell.Value = result.Value
If writeAddressToNextColumn Then
cell.Offset(ColumnOffset:=1).Value = result.Address
End If
PopulateIfFound = True
End If
End Function
Dim source As Range
Set source = wksData.Range("A:A")
PopulateIfFound source, " testtest : ", newRow, 1
PopulateIfFound source, " testflyy : ", newRow, 2
PopulateIfFound source, " testflyy : ", newRow, 3
PopulateIfFound source, " Started at: ", newRow, 4
If Not PopulateIfFound(source, "SmartABC ", newRow, 9) Then
PopulateIfFound source, "smarabcd_efg revision", newRow, 9
End If
If Not PopulateIfFound(source, "ERROR: ABC", newRow, 10, True) Then
PopulateIfFound source, "ERROR: EFG", newRow, 10
End If
