code is working in few data but when I try to load it with 15,000 lines in excel it freeze and not responding
hope you can assist me on this.
IF POSSIBLE TO ADD PROGRESS BAR
Code
Global randomnumber As Double
Sub dailyfilemacro()
'
' dailyfilemacro Macro
'
Dim fieldname(1 To 999999) As String
Dim userid(1 To 999999) As String
Dim useridchangecount(1 To 999999) As Double
Dim useridlines(1 To 999999) As String
Dim vendorlines(1 To 999999) As String
Dim changetype(1 To 999999) As String
Dim user As String
Dim fieldchange As String
Dim vendor As String
Dim m As Double
Dim i As Double
Sheets("Report").Select
Cells.Select
Selection.Delete
Sheets("DailyExport").Select
Dim LastCol As Double
With ActiveSheet
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
LastColChar = Chr(LastCol + 64)
Range("A1").Select
i = 1
ColChar = Chr(i + 64)
Do Until InStr((Range(ColChar & "1").Value), "CHANGE_MADE_DATE") = 1 Or i > LastCol
i = i + 1
ColChar = Chr(i + 64)
Loop
If ColChar <> "A" Then
Columns(ColChar & ":" & ColChar).Select
Application.CutCopyMode = False
Selection.Cut
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
End If
Range("A1").Select
i = 1
ColChar = Chr(i + 64)
Do Until InStr((Range(ColChar & "1").Value), "CHANGE_MADE_TIME") = 1 Or i > LastCol
i = i + 1
ColChar = Chr(i + 64)
Loop
If ColChar <> "B" Then
Columns(ColChar & ":" & ColChar).Select
Application.CutCopyMode = False
Selection.Cut
Columns("B:B").Select
Selection.Insert Shift:=xlToRight
End If
Range("A1").Select
i = 1
ColChar = Chr(i + 64)
Do Until InStr((Range(ColChar & "1").Value), "VENDOR_NUM") = 1 Or i > LastCol
i = i + 1
ColChar = Chr(i + 64)
Loop
If ColChar <> "C" Then
Columns(ColChar & ":" & ColChar).Select
Application.CutCopyMode = False
Selection.Cut
Columns("C:C").Select
Selection.Insert Shift:=xlToRight
End If
Range("A1").Select
i = 1
ColChar = Chr(i + 64)
Do Until InStr((Range(ColChar & "1").Value), "USERID") = 1 Or i > LastCol
i = i + 1
ColChar = Chr(i + 64)
Loop
If ColChar <> "D" Then
Columns(ColChar & ":" & ColChar).Select
Application.CutCopyMode = False
Selection.Cut
Columns("D:D").Select
Selection.Insert Shift:=xlToRight
End If
Range("A1").Select
i = 1
ColChar = Chr(i + 64)
Do Until InStr((Range(ColChar & "1").Value), "FIELD_NAME") = 1 Or i > LastCol
i = i + 1
ColChar = Chr(i + 64)
Loop
If ColChar <> "E" Then
Columns(ColChar & ":" & ColChar).Select
Application.CutCopyMode = False
Selection.Cut
Columns("E:E").Select
Selection.Insert Shift:=xlToRight
End If
Range("A1").Select
i = 1
ColChar = Chr(i + 64)
Do Until InStr((Range(ColChar & "1").Value), "COMPCODE") = 1 Or i > LastCol
i = i + 1
ColChar = Chr(i + 64)
Loop
If ColChar <> "F" Then
Columns(ColChar & ":" & ColChar).Select
Application.CutCopyMode = False
Selection.Cut
Columns("F:F").Select
Selection.Insert Shift:=xlToRight
End If
Range("A1").Select
i = 1
ColChar = Chr(i + 64)
Do Until InStr((Range(ColChar & "1").Value), "PORG") = 1 Or i > LastCol
i = i + 1
ColChar = Chr(i + 64)
Loop
If ColChar <> "G" Then
Columns(ColChar & ":" & ColChar).Select
Application.CutCopyMode = False
Selection.Cut
Columns("G:G").Select
Selection.Insert Shift:=xlToRight
End If
Range("A1").Select
i = 1
ColChar = Chr(i + 64)
Do Until InStr((Range(ColChar & "1").Value), "NEW_VALUE") = 1 Or i > LastCol
i = i + 1
ColChar = Chr(i + 64)
Loop
If ColChar <> "H" Then
Columns(ColChar & ":" & ColChar).Select
Application.CutCopyMode = False
Selection.Cut
Columns("H:H").Select
Selection.Insert Shift:=xlToRight
End If
Range("A1").Select
i = 1
ColChar = Chr(i + 64)
Do Until InStr((Range(ColChar & "1").Value), "OLD_VALUE") = 1 Or i > LastCol
i = i + 1
ColChar = Chr(i + 64)
Loop
If ColChar <> "I" Then
Columns(ColChar & ":" & ColChar).Select
Application.CutCopyMode = False
Selection.Cut
Columns("I:I").Select
Selection.Insert Shift:=xlToRight
End If
LastCol = LastCol + 1
ColChar = Chr(LastCol + 64)
Range(ColChar & "1").Select
Range(ColChar & "1").Value = "Random"
Cells.Select
Cells.EntireColumn.AutoFit
lastRow = Range("A" & Rows.Count).End(xlUp).Row
ActiveWorkbook.Worksheets("DailyExport").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("DailyExport").Sort.SortFields.Add Key:=Range( _
"D2:D" & lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("DailyExport").Sort.SortFields.Add Key:=Range( _
"C2:C" & lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("DailyExport").Sort
.SetRange Range("A1:" & ColChar & lastRow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("C1").Select
i = 1
Do Until i >= lastRow
vendor = Trim(ActiveCell.Offset(i, 0).Value)
user = Trim(ActiveCell.Offset(i, 1).Value)
random_num
Do While Trim(ActiveCell.Offset(i, 0).Value) = vendor And Trim(ActiveCell.Offset(i, 1).Value) = user And i < lastRow
Range(ColChar & (i + 1)).Select
Range(ColChar & (i + 1)).Value = randomnumber
Range("C1").Select
i = i + 1
Loop
Loop
Range("E1").Select
i = 0
Do Until i >= lastRow
If Trim(ActiveCell.Offset(i, 0).Value) = "Authorization" Or Trim(ActiveCell.Offset(i, 0).Value) = "Bank Details" Or Trim(ActiveCell.Offset(i, 0).Value) = "Co.cde deletion flag" Or Trim(ActiveCell.Offset(i, 0).Value) = "Co.code post.block" Or Trim(ActiveCell.Offset(i, 0).Value) = "Company code data" Or Trim(ActiveCell.Offset(i, 0).Value) = "Deletion flag" Or Trim(ActiveCell.Offset(i, 0).Value) = "E-Mail Address" Or Trim(ActiveCell.Offset(i, 0).Value) = "Industry" Or Trim(ActiveCell.Offset(i, 0).Value) = "Payment methods" Or Trim(ActiveCell.Offset(i, 0).Value) = "Payt Terms" Or Trim(ActiveCell.Offset(i, 0).Value) = "Planning group" Or Trim(ActiveCell.Offset(i, 0).Value) = "Posting Block" Or Trim(ActiveCell.Offset(i, 0).Value) = "Tax Number 2" Or Trim(ActiveCell.Offset(i, 0).Value) = "W. Tax Code" Then
ActiveCell.Offset(i, 0).Interior.Color = RGB(255, 0, 0)
End If
If Trim(ActiveCell.Offset(i, 0).Value) = "Confirm.status" Then
ActiveCell.Offset(i, 0).Interior.Color = RGB(0, 255, 0)
End If
i = i + 1
Loop
ActiveWorkbook.Worksheets("DailyExport").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("DailyExport").Sort.SortFields.Add Key:=Range( _
"D2:D" & lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("DailyExport").Sort.SortFields.Add Key:=Range( _
"C2:C" & lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
ActiveWorkbook.Worksheets("DailyExport").Sort.SortFields.Add(Range("E2:E" & lastRow), _
xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(255, 0 _
, 0)
ActiveWorkbook.Worksheets("DailyExport").Sort.SortFields.Add(Range("E2:E" & lastRow), _
xlSortOnCellColor, xlDescending, , xlSortNormal).SortOnValue.Color = RGB(0, 255 _
, 0)
With ActiveWorkbook.Worksheets("DailyExport").Sort
.SetRange Range("A1:" & ColChar & lastRow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("E1").Select
i = 0
Do Until i >= lastRow
If ActiveCell.Offset(i, 0).Interior.Color = RGB(255, 0, 0) Then
vendor = ActiveCell.Offset(i, -2).Value
user = ActiveCell.Offset(i, -1).Value
Do While ActiveCell.Offset(i, -2).Value = vendor And ActiveCell.Offset(i, -1).Value = user
ActiveCell.Offset(i, -1).Interior.Color = RGB(255, 0, 0)
ActiveCell.Offset(i, -2).Interior.Color = RGB(255, 0, 0)
i = i + 1
Loop
i = i - 1
End If
i = i + 1
Loop
ActiveWorkbook.Worksheets("DailyExport").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("DailyExport").Sort.SortFields.Add Key:=Range( _
"D2:D" & lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("DailyExport").Sort.SortFields.Add(Range("D2:D" & lastRow), _
xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(255, 0 _
, 0)
ActiveWorkbook.Worksheets("DailyExport").Sort.SortFields.Add Key:=Range( _
ColChar & "2:" & ColChar & lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("DailyExport").Sort
.SetRange Range("A1:" & ColChar & lastRow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("D1").Select
i = 1
e = 0
m = 1
Do Until i >= lastRow
e = e + 1
userid(e) = Trim(ActiveCell.Offset(i, 0).Value)
useridchangecount(e) = 0
vendorlines(m) = 0
vendor = Trim(ActiveCell.Offset(i, -1).Value)
If ActiveCell.Offset(i, 0).Interior.Color = RGB(255, 0, 0) Then
useridchangecount(e) = useridchangecount(e) + 1
useridlines(m) = userid(e)
vendorlines(m) = Trim(ActiveCell.Offset(i, -1).Value)
changetype(m) = "critical"
m = m + 1
Do Until ActiveCell.Offset(i, 0).Interior.Color <> RGB(255, 0, 0) Or i >= lastRow Or userid(e) <> Trim(ActiveCell.Offset(i, 0).Value)
If Trim(ActiveCell.Offset(i, -1).Value) <> vendor Then
useridchangecount(e) = useridchangecount(e) + 1
useridlines(m) = userid(e)
vendorlines(m) = Trim(ActiveCell.Offset(i, -1).Value)
changetype(m) = "critical"
m = m + 1
vendor = Trim(ActiveCell.Offset(i, -1).Value)
End If
i = i + 1
Loop
End If
Do While Trim(ActiveCell.Offset(i, 0).Value) = userid(e) And useridchangecount(e) < 10 And i < lastRow
If ActiveCell.Offset(i, 1).Interior.Color <> RGB(0, 255, 0) And ActiveCell.Offset.Interior.Color <> RGB(255, 255, 0) And userid(e) <> "< null >" Then
If Trim(ActiveCell.Offset(i, -1).Value) <> vendor Or useridchangecount(e) = 0 Then
useridchangecount(e) = useridchangecount(e) + 1
useridlines(m) = userid(e)
vendorlines(m) = Trim(ActiveCell.Offset(i, -1).Value)
changetype(m) = "non-critical"
m = m + 1
ActiveCell.Offset(i, 0).Interior.Color = RGB(255, 255, 0)
vendor = Trim(ActiveCell.Offset(i, -1).Value)
End If
End If
If Trim(ActiveCell.Offset(i, -1).Value) = vendor Then
ActiveCell.Offset(i, 0).Interior.Color = RGB(255, 255, 0)
ActiveCell.Offset(i, -1).Interior.Color = RGB(255, 255, 0)
End If
i = i + 1
Loop
Do Until Trim(ActiveCell.Offset(i, 0).Value) <> userid(e) Or i >= lastRow
i = i + 1
Loop
Loop
laste = e
lastm = m
e = 1
m = 1
Sheets("Report").Select
Range("A1").Select
Range("A1").Value = "UserID"
Range("B1").Select
Range("B1").Value = "Vendor Audit Count"
Range("A1").Select
Do Until e > laste
ActiveCell.Offset(e, 0).Value = userid(e)
ActiveCell.Offset(e, 1).Value = useridchangecount(e)
e = e + 1
Loop
Range("D1").Select
Range("D1").Value = "UserID"
Range("E1").Select
Range("E1").Value = "Vendor Code"
Range("F1").Select
Range("F1").Value = "Change Type"
Range("D1").Select
Do Until m > lastm
ActiveCell.Offset(m, 0).Value = useridlines(m)
ActiveCell.Offset(m, 1).Value = vendorlines(m)
ActiveCell.Offset(m, 2).Value = changetype(m)
m = m + 1
Loop
Cells.Select
Cells.EntireColumn.AutoFit
End Sub
Sub random_num()
'Initialize the random number generator
'=> Randomize : add this before you call the Rnd function to obtain completely random values
Randomize
'Random whole number between 1 and 50 :
randomnumber = Int(50 * Rnd) + 1
End Sub
Display More