A little background: Been working on a file which is accessible by 80 users (concurrent would probably be 10 at a time). Say the sales team leaders need to activate a button to activate codes below to read from another file (A) with 3 sheets of 20000 records per sheet (A.1, A.2, A.3), to read line by line to match the copy and paste into the current file based on the names of each sales person based on criteria.
It seemed to take a long time as each leader has 20 sales staff and the code seemed to jam excel though ;(
If the file it's reading from consists of about 1000 lines or something, it works pretty smooth though.
Hope someone could enlighten me.
Option Explicit
Sub T1CopyDataFromAnotherFileIfSearchTextIsFound()
'Clear Existing Content
Sheets("4").Cells.ClearContents
Sheets("5").Cells.ClearContents
Sheets("6").Cells.ClearContents
Sheets("7").Cells.ClearContents
Sheets("8").Cells.ClearContents
Sheets("9").Cells.ClearContents
Sheets("10").Cells.ClearContents
Sheets("11").Cells.ClearContents
Sheets("12").Cells.ClearContents
Sheets("13").Cells.ClearContents
Sheets("14").Cells.ClearContents
Sheets("15").Cells.ClearContents
Sheets("16").Cells.ClearContents
Sheets("17").Cells.ClearContents
Sheets("18").Cells.ClearContents
Sheets("19").Cells.ClearContents
Sheets("20").Cells.ClearContents
Sheets("21").Cells.ClearContents
Sheets("22").Cells.ClearContents
Sheets("23").Cells.ClearContents
'Team 1 Content Copy >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Dim Name1, Name4, Name5, Name6, Name7, Name8, Name9, Name10, Name11, Name12, Name13, Name14, Name15, Name16, Name17, Name18, Name19, Name20, Name21, Name22, Name23 As String
Dim strPath As String
Dim wbkImportFile As Workbook
Dim shtThisSheet As Worksheet
Dim shtImportSheet1 As Worksheet
Dim shtImportSheet2 As Worksheet
Dim shtImportSheet3 As Worksheet
Dim lngrow As Long
Dim strSearchString As String
Dim strImportFile As String
Name1 = Sheets("UserAccessAcc").Range("B3").Value
Name4 = Sheets("UserAccessAcc").Range("B6").Value
Name5 = Sheets("UserAccessAcc").Range("B7").Value
Name6 = Sheets("UserAccessAcc").Range("B8").Value
Name7 = Sheets("UserAccessAcc").Range("B9").Value
Name8 = Sheets("UserAccessAcc").Range("B10").Value
Name9 = Sheets("UserAccessAcc").Range("B11").Value
Name10 = Sheets("UserAccessAcc").Range("B12").Value
Name11 = Sheets("UserAccessAcc").Range("B13").Value
Name12 = Sheets("UserAccessAcc").Range("B14").Value
Name13 = Sheets("UserAccessAcc").Range("B15").Value
Name14 = Sheets("UserAccessAcc").Range("B16").Value
Name15 = Sheets("UserAccessAcc").Range("B17").Value
Name16 = Sheets("UserAccessAcc").Range("B18").Value
Name17 = Sheets("UserAccessAcc").Range("B19").Value
Name18 = Sheets("UserAccessAcc").Range("B20").Value
Name19 = Sheets("UserAccessAcc").Range("B21").Value
Name20 = Sheets("UserAccessAcc").Range("B22").Value
Name21 = Sheets("UserAccessAcc").Range("B23").Value
Name22 = Sheets("UserAccessAcc").Range("B24").Value
Name23 = Sheets("UserAccessAcc").Range("B25").Value
strPath = ThisWorkbook.Path
strImportFile = "Book1.xlsx"
On Error GoTo Errorhandler
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
Set wbkImportFile = Workbooks.Open(Filename:=strPath & "" & strImportFile, ReadOnly:=True, UpdateLinks:=False)
'Account1>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'strSearchString = Name1
'Set shtThisSheet = ThisWorkbook.Worksheets("1")
Set shtImportSheet1 = wbkImportFile.Worksheets("6-9 Months")
Set shtImportSheet2 = wbkImportFile.Worksheets("10-24 Months")
Set shtImportSheet3 = wbkImportFile.Worksheets("25-36 Months")
With shtImportSheet1
.Columns("L").Insert
.Columns("L").Insert
End With
'Account4>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
strSearchString = Name4
Set shtThisSheet = ThisWorkbook.Worksheets("4")
With shtThisSheet.Range("A1")
.Offset(0, 0).Value = "memberid"
.Offset(0, 1).Value = "firstname"
.Offset(0, 2).Value = "lastname"
.Offset(0, 3).Value = "country"
.Offset(0, 4).Value = "ADT"
.Offset(0, 5).Value = "Team"
.Offset(0, 6).Value = "Lastgamingdt"
.Offset(0, 7).Value = "Type"
.Offset(0, 8).Value = "predom"
.Offset(0, 9).Value = "playStatus"
.Offset(0, 10).Value = "HostName"
.Offset(0, 11).Value = "HostLogin"
.Offset(0, 12).Value = "Campaign"
.Offset(0, 13).Value = "GamingOfferType"
.Offset(0, 14).Value = "OfferAmount"
.Offset(0, 15).Value = "Tagcode"
.Offset(0, 16).Value = "TagcodeDescription"
.Offset(0, 17).Value = "Comments"
End With
For lngrow = 2 To shtImportSheet1.Cells(shtImportSheet1.Rows.Count, "K").End(xlUp).Row
If InStr(1, shtImportSheet1.Cells(lngrow, "K").Value2, strSearchString, vbTextCompare) > 0 Then
'With shtImportSheet1
''.Columns("L").Insert
''.Columns("L").Insert
'End With
shtImportSheet1.Range(shtImportSheet1.Cells(lngrow, 1), shtImportSheet1.Cells(lngrow, 18)).Copy
shtThisSheet.Range("A" & shtThisSheet.Cells(shtThisSheet.Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteAll, xlPasteSpecialOperationNone
End If
Next lngrow
For lngrow = 2 To shtImportSheet2.Cells(shtImportSheet1.Rows.Count, "K").End(xlUp).Row
If InStr(1, shtImportSheet2.Cells(lngrow, "K").Value2, strSearchString, vbTextCompare) > 0 Then
shtImportSheet2.Range(shtImportSheet2.Cells(lngrow, 1), shtImportSheet2.Cells(lngrow, 18)).Copy
shtThisSheet.Range("A" & shtThisSheet.Cells(shtThisSheet.Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteAll, xlPasteSpecialOperationNone
End If
Next lngrow
For lngrow = 2 To shtImportSheet3.Cells(shtImportSheet1.Rows.Count, "K").End(xlUp).Row
If InStr(1, shtImportSheet3.Cells(lngrow, "K").Value2, strSearchString, vbTextCompare) > 0 Then
shtImportSheet3.Range(shtImportSheet3.Cells(lngrow, 1), shtImportSheet3.Cells(lngrow, 18)).Copy
shtThisSheet.Range("A" & shtThisSheet.Cells(shtThisSheet.Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteAll, xlPasteSpecialOperationNone
End If
Next lngrow
'Account5>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
strSearchString = Name5
Set shtThisSheet = ThisWorkbook.Worksheets("5")
With shtThisSheet.Range("A1")
.Offset(0, 0).Value = "memberid"
.Offset(0, 1).Value = "firstname"
.Offset(0, 2).Value = "lastname"
.Offset(0, 3).Value = "country"
.Offset(0, 4).Value = "ADT"
.Offset(0, 5).Value = "Team"
.Offset(0, 6).Value = "Lastgamingdt"
.Offset(0, 7).Value = "Type"
.Offset(0, 8).Value = "predom"
.Offset(0, 9).Value = "playStatus"
.Offset(0, 10).Value = "HostName"
.Offset(0, 11).Value = "HostLogin"
.Offset(0, 12).Value = "Campaign"
.Offset(0, 13).Value = "GamingOfferType"
.Offset(0, 14).Value = "OfferAmount"
.Offset(0, 15).Value = "Tagcode"
.Offset(0, 16).Value = "TagcodeDescription"
.Offset(0, 17).Value = "Comments"
End With
For lngrow = 2 To shtImportSheet1.Cells(shtImportSheet1.Rows.Count, "K").End(xlUp).Row
If InStr(1, shtImportSheet1.Cells(lngrow, "K").Value2, strSearchString, vbTextCompare) > 0 Then
With shtImportSheet1
''.Columns("L").Insert
''.Columns("L").Insert
End With
shtImportSheet1.Range(shtImportSheet1.Cells(lngrow, 1), shtImportSheet1.Cells(lngrow, 18)).Copy
shtThisSheet.Range("A" & shtThisSheet.Cells(shtThisSheet.Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteAll, xlPasteSpecialOperationNone
End If
Next lngrow
For lngrow = 2 To shtImportSheet2.Cells(shtImportSheet1.Rows.Count, "K").End(xlUp).Row
If InStr(1, shtImportSheet2.Cells(lngrow, "K").Value2, strSearchString, vbTextCompare) > 0 Then
shtImportSheet2.Range(shtImportSheet2.Cells(lngrow, 1), shtImportSheet2.Cells(lngrow, 18)).Copy
shtThisSheet.Range("A" & shtThisSheet.Cells(shtThisSheet.Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteAll, xlPasteSpecialOperationNone
End If
Next lngrow
For lngrow = 2 To shtImportSheet3.Cells(shtImportSheet1.Rows.Count, "K").End(xlUp).Row
If InStr(1, shtImportSheet3.Cells(lngrow, "K").Value2, strSearchString, vbTextCompare) > 0 Then
shtImportSheet3.Range(shtImportSheet3.Cells(lngrow, 1), shtImportSheet3.Cells(lngrow, 18)).Copy
shtThisSheet.Range("A" & shtThisSheet.Cells(shtThisSheet.Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteAll, xlPasteSpecialOperationNone
End If
Next lngrow
'Account6>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
strSearchString = Name6
Set shtThisSheet = ThisWorkbook.Worksheets("6")
With shtThisSheet.Range("A1")
.Offset(0, 0).Value = "memberid"
.Offset(0, 1).Value = "firstname"
.Offset(0, 2).Value = "lastname"
.Offset(0, 3).Value = "country"
.Offset(0, 4).Value = "ADT"
.Offset(0, 5).Value = "Team"
.Offset(0, 6).Value = "Lastgamingdt"
.Offset(0, 7).Value = "Type"
.Offset(0, 8).Value = "predom"
.Offset(0, 9).Value = "playStatus"
.Offset(0, 10).Value = "HostName"
.Offset(0, 11).Value = "HostLogin"
.Offset(0, 12).Value = "Campaign"
.Offset(0, 13).Value = "GamingOfferType"
.Offset(0, 14).Value = "OfferAmount"
.Offset(0, 15).Value = "Tagcode"
.Offset(0, 16).Value = "TagcodeDescription"
.Offset(0, 17).Value = "Comments"
End With
For lngrow = 2 To shtImportSheet1.Cells(shtImportSheet1.Rows.Count, "K").End(xlUp).Row
If InStr(1, shtImportSheet1.Cells(lngrow, "K").Value2, strSearchString, vbTextCompare) > 0 Then
With shtImportSheet1
''.Columns("L").Insert
''.Columns("L").Insert
End With
shtImportSheet1.Range(shtImportSheet1.Cells(lngrow, 1), shtImportSheet1.Cells(lngrow, 18)).Copy
shtThisSheet.Range("A" & shtThisSheet.Cells(shtThisSheet.Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteAll, xlPasteSpecialOperationNone
End If
Next lngrow
For lngrow = 2 To shtImportSheet2.Cells(shtImportSheet1.Rows.Count, "K").End(xlUp).Row
If InStr(1, shtImportSheet2.Cells(lngrow, "K").Value2, strSearchString, vbTextCompare) > 0 Then
shtImportSheet2.Range(shtImportSheet2.Cells(lngrow, 1), shtImportSheet2.Cells(lngrow, 18)).Copy
shtThisSheet.Range("A" & shtThisSheet.Cells(shtThisSheet.Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteAll, xlPasteSpecialOperationNone
End If
Next lngrow
For lngrow = 2 To shtImportSheet3.Cells(shtImportSheet1.Rows.Count, "K").End(xlUp).Row
If InStr(1, shtImportSheet3.Cells(lngrow, "K").Value2, strSearchString, vbTextCompare) > 0 Then
shtImportSheet3.Range(shtImportSheet3.Cells(lngrow, 1), shtImportSheet3.Cells(lngrow, 18)).Copy
shtThisSheet.Range("A" & shtThisSheet.Cells(shtThisSheet.Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteAll, xlPasteSpecialOperationNone
End If
Next lngrow
wbkImportFile.Close SaveChanges:=False
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
Sheets("Summary Report View").Select
MsgBox ("Team 1 Cold Call Data Refresh Completed")
End Sub
''>>>>>>>>Account4 onwards to repeat same codes for account 5 - 20..
Aucun commentaire:
Enregistrer un commentaire