excel-Vba for loop with If condition taking long time - vba

I am very much a novice with VBA but i have managed to write code that runs. My issue is that when i run it with many thousands of rows it basically grinds to a halt and nothing happens for well over an hour (when i run for 150K rows). On top of my code i have added:
I have also attempted to avoid using .select whenever i could. Is there anything that i'm missing or is there a way that i could improve my code? Since i've pasted various code i'm sure i've done something wrong.
Sub Eng11()
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim Last As Long
Dim i As Long
Dim wkb1 As Workbook
Dim sht1 As Worksheet
Dim wkb2 As Workbook
Dim sht2 As Worksheet
Dim lastrow As Long
Dim sPath As String, sFile As String
Dim wb As Workbook
Dim x As Long
Dim ws As Worksheet
sPath = "C:\Users\nascd\Downloads\Pronto Master\"
sFile = sPath & Sheets("Sheet 1").Range("J2").Text
Set wkb1 = ThisWorkbook
Set wkb2 = Workbooks.Open(sFile)
Set sht1 = wkb1.Sheets("Data Table")
Set sht2 = wkb2.Sheets("Sheet1")
Set ws = sht2
Last = Cells(Rows.Count, "AX").End(xlUp).Row
For i = Last To 2 Step -1
If (Cells(i, "AZ").Text) = (Cells(i, "AB").Text) And _
(Cells(i, "BA").Text) = (Cells(i, "AC").Text) And _
(Cells(i, "AY").Text) = "C" And (Cells(i, "AA").Text) = "E" Then
Cells(i, "AX").Value = Cells(i, "Z").Value
Cells(i, "AY").Value = Cells(i, "AA").Value
Cells(i, "AZ").Value = Cells(i, "AB").Value
Cells(i, "BA").Value = Cells(i, "AC").Value
End If
Next i
For i = Last To 2 Step -1
If (Cells(i, "AZ").Text) = (Cells(i, "AB").Text) And _
(Cells(i, "BA").Text) = (Cells(i, "AC").Text) And _
(Cells(i, "AY").Text) = "C" And (Cells(i, "AA").Text) = "T" Then
Cells(i, "AX").Value = Cells(i, "Z").Value
Cells(i, "AY").Value = Cells(i, "AA").Value
Cells(i, "AZ").Value = Cells(i, "AB").Value
Cells(i, "BA").Value = Cells(i, "AC").Value
End If
Next i
For i = Last To 2 Step -1
If (Cells(i, "AY").Text) = "1" And (Cells(i, "AA").Text) = "E" Then
Cells(i, "AX").Value = Cells(i, "Z").Value
Cells(i, "AY").Value = Cells(i, "AA").Value
Cells(i, "AZ").Value = Cells(i, "AB").Value
Cells(i, "BA").Value = Cells(i, "AC").Value
End If
Next i
For i = Last To 2 Step -1
If (Cells(i, "AY").Text) = "2" And (Cells(i, "AA").Text) = "E" Then
Cells(i, "AX").Value = Cells(i, "Z").Value
Cells(i, "AY").Value = Cells(i, "AA").Value
Cells(i, "AZ").Value = Cells(i, "AB").Value
Cells(i, "BA").Value = Cells(i, "AC").Value
End If
Next i
End Sub

I think that this is as condensed as I can make it. Certainly some logic magician could come in and make this shorter but I think they might not be able to fit the if logic onto a single line!
This will only loop once, which should have been your biggest obstacle in terms of time to run. I made sure to specify that you're searching in sht2, removed some unused variables, and made sure to reset your application settings at the end of the sub. Other than that, the only thing I really did was combine your if statements as best as I could and put them into one loop.
Sub Eng11()
With Application
.DisplayAlerts = False
.AskToUpdateLinks = False
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
Dim sht1 As Worksheet
Set sht1 = ThisWorkbook.Sheets("Data Table")
Dim sPath As String
sPath = "C:\Users\nascd\Downloads\Pronto Master\"
Dim sFile As String
sFile = sPath & sht1.Range("J2").Value2
Dim sht2 As Worksheet
Set sht2 = Workbooks.Open(sFile).Sheets(1)
Dim lastRow As Long
lastRow = sht2.Cells(Rows.count, "AX").End(xlUp).row
Dim i As Long
For i = 2 To lastRow
With sht2
If .Cells(i, "AZ").Value2 = .Cells(i, "AB").Value2 And _
.Cells(i, "BA").Value2 = .Cells(i, "AC").Value2 Then
If .Cells(i, "AY").Value2 = "C" And _
(.Cells(i, "AA").Value2 = "E" Or .Cells(i, "AA").Value2 = "T") Then
.Cells(i, "AX").Value2 = .Cells(i, "Z").Value2
.Cells(i, "AY").Value2 = .Cells(i, "AA").Value2
.Cells(i, "AZ").Value2 = .Cells(i, "AB").Value2
.Cells(i, "BA").Value2 = .Cells(i, "AC").Value2
End If
ElseIf .Cells(i, "AA").Value2 = "E" And _
(.Cells(i, "AY").Value2 = 2 Or .Cells(i, "AY").Value2 = 1) Then
.Cells(i, "AX").Value2 = .Cells(i, "Z").Value2
.Cells(i, "AY").Value2 = .Cells(i, "AA").Value2
.Cells(i, "AZ").Value2 = .Cells(i, "AB").Value2
.Cells(i, "BA").Value2 = .Cells(i, "AC").Value2
End If
End With
Next i
With Application
.DisplayAlerts = True
.AskToUpdateLinks = True
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub

Sub Eng11()
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim Last As Long
Dim i As Long
Dim wkb1 As Workbook
Dim sht1 As Worksheet
Dim wkb2 As Workbook
Dim sht2 As Worksheet
Dim lastrow As Long
Dim sPath As String, sFile As String
Dim wb As Workbook
Dim x As Long
Dim ws As Worksheet
sPath = "C:\Users\nascd\Downloads\Pronto Master\"
sFile = sPath & Sheets("Sheet 1").Range("J2").Text
Set wkb1 = ThisWorkbook
Set wkb2 = Workbooks.Open(sFile)
Set sht1 = wkb1.Sheets("Data Table")
Set sht2 = wkb2.Sheets("Sheet1")
Set ws = sht2
Last = Cells(Rows.Count, "AX").End(xlUp).Row
For i = Last To 2 Step -1
If (Cells(i, "AZ").Text) = (Cells(i, "AB").Text) And _
(Cells(i, "BA").Text) = (Cells(i, "AC").Text) And _
(Cells(i, "AY").Text) = "C" And (Cells(i, "AA").Text) = "E" Then
Cells(i, "AX").Value = Cells(i, "Z").Value
Cells(i, "AY").Value = Cells(i, "AA").Value
Cells(i, "AZ").Value = Cells(i, "AB").Value
Cells(i, "BA").Value = Cells(i, "AC").Value
End If
If (Cells(i, "AZ").Text) = (Cells(i, "AB").Text) And _
(Cells(i, "BA").Text) = (Cells(i, "AC").Text) And _
(Cells(i, "AY").Text) = "C" And (Cells(i, "AA").Text) = "T" Then
Cells(i, "AX").Value = Cells(i, "Z").Value
Cells(i, "AY").Value = Cells(i, "AA").Value
Cells(i, "AZ").Value = Cells(i, "AB").Value
Cells(i, "BA").Value = Cells(i, "AC").Value
End If
If (Cells(i, "AY").Text) = "1" And (Cells(i, "AA").Text) = "E" Then
Cells(i, "AX").Value = Cells(i, "Z").Value
Cells(i, "AY").Value = Cells(i, "AA").Value
Cells(i, "AZ").Value = Cells(i, "AB").Value
Cells(i, "BA").Value = Cells(i, "AC").Value
End If
If (Cells(i, "AY").Text) = "2" And (Cells(i, "AA").Text) = "E" Then
Cells(i, "AX").Value = Cells(i, "Z").Value
Cells(i, "AY").Value = Cells(i, "AA").Value
Cells(i, "AZ").Value = Cells(i, "AB").Value
Cells(i, "BA").Value = Cells(i, "AC").Value
End If
Next i
End Sub
Can you pardon to let me the know the difference of last two Ifs as the function is same for both ifs condition.

Related

VBA , Using offset

I am having 4 sht, sht1, sht2, sht3 and sht4.
I am copying the columns E and F from sht 1 to sht3. and then i look into the corresponding values in sht 2, and paste them in sht3.
I then lookinto in my sht3, if the column "G" has "NO"; then i copy the corresponding rows to sht4.
till, this i have completed coding.
I wanted to look into the column E in sht4, and paste the corresponding ID from sht1. Could someone tell, how i could do it ?
EDIT.
In sht3, i have the rows filled only when there is Id in column F.
In few cases, i dont have column F,means there is no ID.
so, i copy them to sht4. Now i have in sht4, column E Filled. I want to look into the relevant Information of those ID in sht1. I want the Information from each and every column in sht1, except E .
I know we can use Offset, but how do I use it in this case,
I have tried the following code
Sub nlookup()
Dim i As Long
Dim totalrows As Long
Dim rng As Range
Sheets("sht1").Select
totalrows = ActiveSheet.UsedRange.Rows.Count
Sheets("sht4").Select
For i = 5 To totalrows
Set rng = Sheets("sht2").UsedRange.Find(Cells(i, 5).Value)
'If it is found put its value on the destination sheet
If Not rng Is Nothing Then
Cells(i, 6).Value = rng.Value
Cells(i, 1).Value = rng.Offset(0, 0).Value
Cells(i, 2).Value = rng.Offset(0, 14).Value
Cells(i, 3).Value = rng.Offset(0, 1).Value
Cells(i, 4).Value = rng.Offset(0, 2).Value
Cells(i, 12).Value = rng.Offset(0, 8).Value
Cells(i, 13).Value = rng.Offset(0, 9).Value
End If
Next
End Sub
Set rng = Sheets("sht2").UsedRange.Find(Cells(i, 5).Value), there is no Need of looking into this line, i beleive.
The code will consider the following as discussed in chat:
Data should be copied from sht1 to sht4 on Id's in both sheets
Id's are in Column L and Column E for sht1 and sht4 respectively
Columns to be copy from sht1 to sht4 as A->A, B->C,C->D,I->L,J->M,O->B
Data in sht1 and sht4 starts from Row 5 and Row 2 respectively
Sub Demo()
Dim srcLastRow As Long, destLastRow As Long
Dim srcWS As Worksheet, destWS As Worksheet
Dim i As Long, j As Long
Application.ScreenUpdating = False
Set srcWS = ThisWorkbook.Sheets("Sht1")
Set destWS = ThisWorkbook.Sheets("Sht4")
srcLastRow = srcWS.Cells(srcWS.Rows.Count, "L").End(xlUp).Row
destLastRow = destWS.Cells(destWS.Rows.Count, "E").End(xlUp).Row
For i = 2 To destLastRow
For j = 5 To srcLastRow
If destWS.Cells(i, "E").Value = srcWS.Cells(j, "L").Value Then
destWS.Cells(i, "A") = srcWS.Cells(j, "A")
destWS.Cells(i, "B") = srcWS.Cells(j, "O")
destWS.Cells(i, "C") = srcWS.Cells(j, "B")
destWS.Cells(i, "D") = srcWS.Cells(j, "C")
destWS.Cells(i, "L") = srcWS.Cells(j, "I")
destWS.Cells(i, "M") = srcWS.Cells(j, "J")
End If
Next j
Next i
Application.ScreenUpdating = True
End Sub
Why not just use Cells(i, 4).Value = rng.Cells(i, 6).Value ?
Also get rid of the.Select
Sub nlookup()
dim sht as Worksheet
Dim i As Long
Dim totalrows As Long
Dim rng As Range
totalrows = Sheets("sht1").UsedRange.Rows.Count
Set sht = Worksheets("sht4")
For i = 5 To totalrows
Set rng = Sheets("sht2").UsedRange.Find(sht.Cells(i, 5).Value)
'If it is found put its value on the destination sheet
If Not rng Is Nothing Then
sht.Cells(i, 6).Value = rng.Value
sht.Cells(i, 1).Value = rng.Cells(i, 1).Value
sht.Cells(i, 2).Value = rng.Cells(i, 16).Value
sht.Cells(i, 3).Value = rng.Cells(i, 4).Value
sht.Cells(i, 4).Value = rng.Cells(i, 6).Value
sht.Cells(i, 12).Value = rng.Cells(i, 20).Value
sht.Cells(i, 13).Value = rng.Cells(i, 22).Value
End If
Next
End Sub

Dynamic field population VBA

I have written a script that simplifies a spreadsheet, but I need help with dynamically populating fields. The current format of the spreadsheet has inconsistent spacing so it is difficult to put together and if then statement that populates only populates subsections of a document.
I have attached an of the way the document looks.
What I am trying to do is populate the Highlighted fields on the left based on the highlighted field on the right. e.g. (When Field "F3" populated - If "2012" and "092000" then populate BBFY with "2012" from cell "F2" in cells "A4" to "A11" Stop at last BOC number".) Start same process at next process with next group of data. Then if there is new data for the BOC name 2013 092300, fill in the corresponding information based on that information.
I am just having trouble trying to identify the correct calls to many changes are making it difficult to tell the code to change values based on new parameters. As you can see the highlighted values in F change and thus change the related information below. I have blocked out where I am trying to start up this section of the code.
The code I have so far gets me to the layout you see below. In addition I am trying to make a new worksheet based off of each section, but I will try to tackle that another time.
Sub SOFCMacro()
'Begins Macro Optimizations
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
'Declarations
Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
Dim rng As Range
'Renames Sheet1 and Make It an Object
Set Main = ActiveSheet
Main.Name = "BAR"
'Add and Name Worksheets
Set WS1 = Sheets.Add
WS1.Name = "SOFC"
'Clear Formatting
Sheets("BAR").Activate
With ActiveSheet
.Cells.ClearFormats
End With
***'Comma Diliminate Funding Information
Sheets("Bar").Activate
With ActiveSheet
Set rng = .Range(rng, .Cells(.Rows.Count, rng.Column).End(xlUp))
For i = Last To 1 Step -1
If Not IsError(.vaule) Then
ElseIf (cells(i, "F").value = "092000:" and "Salaries:" Then cells(Cells, i, "A").value = (Cells(i, "F").Value) Like "20*"
ElseIf .value = "092300:" and "Defender:" Then cells(Cells, i, "A").value = (Cells(i, "F").Value) Like "20*"
ElseIf .value = "51140X:" and "Judiciary:" Then cells(Cells, i, "A").value = (Cells(i, "F").Value) Like "20*"
ElseIf .value = "51140E:" and "Electronic:" Then cells(Cells, i, "A").value = (Cells(i, "F").Value) Like "20*"
End if
End With***
'Copies Columns from Budget Availability Reports to SOFC Worksheet
Sheets("BAR").Columns(1).Copy Destination:=Sheets("SOFC").Columns(4)
Sheets("BAR").Columns(2).Copy Destination:=Sheets("SOFC").Columns(5)
Sheets("BAR").Columns(3).Copy Destination:=Sheets("SOFC").Columns(6)
Sheets("BAR").Columns(4).Copy Destination:=Sheets("SOFC").Columns(7)
'Deletes "Main Worksheet"
Sheets("BAR").Delete
'Inserts Header Row
Sheets("SOFC").Range("A2").EntireRow.Insert
'Add Headers to Sheet
Sheets("SOFC").Range("A1").Value = "BBFY"
Sheets("SOFC").Range("B1").Value = "EBFY"
Sheets("SOFC").Range("C1").Value = "FUND"
Sheets("SOFC").Range("D1").Value = "BUDGET ORG"
Sheets("SOFC").Range("E1").Value = "BOC"
Sheets("SOFC").Range("F1").Value = "BOC Name"
Sheets("SOFC").Range("G1").Value = "ALLOTMENT"
'Deletes Unneeded Rows
Sheets("SOFC").Activate
With ActiveSheet
Firstrow = .UsedRange.Cells(1).Row
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
For Lrow = Lastrow To Firstrow Step -1
With .Cells(Lrow, "D")
If Not IsError(.Value) Then
ElseIf .Value = "Activity Type:" Then .EntireRow.Delete
ElseIf .Value = "Activity:" Then .EntireRow.Delete
ElseIf .Value = "AO Division:" Then .EntireRow.Delete
End If
End With
Next Lrow
End With
'Deletes Rows Based On Criteria
Last = Cells(Rows.Count, "D").End(xlUp).Row
For i = Last To 1 Step -1
If (Cells(i, "D").Value) = "Fund:" Then
'Cells(i, "A").EntireRow.ClearContents ' USE THIS TO CLEAR CONTENTS BUT NOT DELETE ROW
ElseIf (Cells(i, "D").Value) = "Activity Type:" Then
Cells(i, "A").EntireRow.Delete
ElseIf (Cells(i, "D").Value) = "Activity:" Then
Cells(i, "A").EntireRow.Delete
ElseIf (Cells(i, "D").Value) = "AO Division:" Then
Cells(i, "A").EntireRow.Delete
ElseIf (Cells(i, "D").Value) = " Org Code" Then
Cells(i, "A").EntireRow.Delete
ElseIf (Cells(i, "F").Value) = "Org Code Subtotal:" Then
Cells(i, "A").EntireRow.Delete
ElseIf (Cells(i, "F").Value) = "AO Division Subtotal:" Then
Cells(i, "A").EntireRow.Delete
ElseIf (Cells(i, "F").Value) = "Activity Subtotal:" Then
Cells(i, "A").EntireRow.Delete
ElseIf (Cells(i, "F").Value) = "Activity Type Subtotal:" Then
Cells(i, "A").EntireRow.Delete
ElseIf (Cells(i, "F").Value) = "Fund Subtotal:" Then
Cells(i, "A").EntireRow.Delete
'Change Values for Courts in Current Wave
ElseIf (Cells(i, "F").Value) = "ARW - Arkansas Western" Then
Cells(i, "A").EntireRow.Delete
ElseIf (Cells(i, "F").Value) = "CAN - California Northern" Then
Cells(i, "A").EntireRow.Delete
ElseIf (Cells(i, "F").Value) = "GAS - Georgia Southern" Then
Cells(i, "A").EntireRow.Delete
ElseIf (Cells(i, "F").Value) = "MDX - Maryland" Then
Cells(i, "A").EntireRow.Delete
ElseIf (Cells(i, "F").Value) = "NDX - North Dakota" Then
Cells(i, "A").EntireRow.Delete
ElseIf (Cells(i, "F").Value) = "NYE - New York Eastern" Then
Cells(i, "A").EntireRow.Delete
ElseIf (Cells(i, "F").Value) = "ORX - Oregon" Then
Cells(i, "A").EntireRow.Delete
ElseIf (Cells(i, "F").Value) = "SDX - South Dakota" Then
Cells(i, "A").EntireRow.Delete
'Change Values for Courts in Current Wave
ElseIf (Cells(i, "F").Value) = "" Then
Cells(i, "A").EntireRow.Delete
Else
End If
Next i
'Gets BBFY and Fund and Place Values in Correct Columns
'Last = Cells(Rows.Count, "D").End(xlUp).Row
For i = Last To 1 Step -1
If (Cells(i, "D").Value) = "Fund:" Then
ElseIf (Cells(i, "F").Value) Like "20*" Then
YearYo = Left(Cells(i, "20*"), 4)
If Date Like "20*" Then
Cells(i, "A").Value = Date
End If
Else
End If
Next i
'Gets Leading 0 for Fund Code
Columns("C:C").Select
Selection.NumberFormat = "000000"
End Sub
One suggestion, if your spreadsheet is consistent in the BOC column, then maybe that's the best place to start.
Dim i as Integer
Dim j as Integer
Dim LR as Long
LR = Cells(Sheets("NAME").Columns(6).Rows.Count, 1).End(xlUp).Row
For j = 1 to LR
For i = 1 to 3
If Cells(j,i)/Value="" Then
Cells(j,i).Formula= 'come up with reference for the BOC Name
Else:
End If
Next i
Next j
It's not perfect and could probably be done better with a For Each (I'm not very good with those), but it could be at least a start. This option doesn't find dynamic ranges to fill in the blank (e.g. dynamically define the big yellow block of squares and paste into them). It just loops through all cells in the first 3 rows, til the end of the last row (used column F (Columns(6)) as is seems to be your only fully filled column).
If you want more specific to what goes into each cell:
Dim i as Integer
Dim LR as Long
LR = Cells(Sheets("NAME").Columns(6).Rows.Count, 1).End(xlUp).Row
For i = 1 to LR
If Cells(i,1)/Value="" Then
Cells(i,1).Formula= "=Left(REF,4)'come up with reference for the BOC Name
Cells(i,2).Formula= "=Left(Right(REF,6),11)
Cells(i,3).Formula= "=Right(REF,3)
Else:
End If
Next i

pasteSpecial method of Range class failed

sometimes I don't get Excel VBA, I am just copying data from one sheet to another but I get the error :
pasteSpecial method of Range class failed
I copy some date from a source in the internet, paste it in "temporary" sheet,deleted some columns, do some calculations, and paste it into "final" sheet.
here is my code:
Sub copying()
'
' copying Macro
'
Application.Calculation = xlManual
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim tempSheet As Worksheet
Set tempSheet = ThisWorkbook.Sheets("temporary")
tempSheet.Activate
tempSheet.Cells.ClearFormats
tempSheet.Cells(4, 1).Select
ActiveSheet.Paste
Columns(4).Select
Selection.Cut
Columns(3).Select
ActiveSheet.Paste
Columns(6).Select
Selection.Cut
Columns(4).Select
ActiveSheet.Paste
'
Columns(7).Select
Selection.Cut
Columns(5).Select
ActiveSheet.Paste
Columns(8).Select
Selection.ClearFormats
Columns(8).Select
Selection.Cut
Columns(6).Select
ActiveSheet.Paste
Columns(9).Select
Selection.Cut
Columns(7).Select
ActiveSheet.Paste
Columns(19).Select
Selection.Cut
Columns(8).Select
ActiveSheet.Paste
Columns(21).Select
Selection.Cut
Columns(9).Select
ActiveSheet.Paste
Columns(10).Select
Selection.ClearFormats
Selection.ClearContents
Columns(73).Select
Selection.Cut
Columns(11).Select
ActiveSheet.Paste
Columns(23).Select
Selection.Cut
Columns(12).Select
ActiveSheet.Paste
Columns(25).Select
Selection.Cut
Columns(13).Select
ActiveSheet.Paste
Columns(14).Select
Selection.ClearFormats
Selection.ClearContents
Columns(37).Select
Selection.Cut
Columns(21).Select
ActiveSheet.Paste
Columns(22).Select
Selection.ClearFormats
Selection.ClearContents
Columns(76).Select
Selection.Cut
Columns(23).Select
ActiveSheet.Paste
Range("X1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.ClearContents
Columns("E:E").Select
Selection.NumberFormat = "m/d/yyyy"
Columns("F:F").Select
Selection.NumberFormat = "m/d/yyyy"
Columns("L:L").Select
Selection.NumberFormat = "0.00"
Columns("H:H").Select
Selection.NumberFormat = "0.00"
Columns(8).Select
Selection.NumberFormat = "0.00"
Columns(9).Select
Selection.NumberFormat = "0.00"
Columns(10).Select
Selection.NumberFormat = "0.00"
Columns(12).Select
Selection.NumberFormat = "0.00"
Columns(13).Select
Selection.NumberFormat = "0.00"
Columns(14).Select
Selection.NumberFormat = "0.00"
Columns(16).Select
Selection.NumberFormat = "0.00"
Columns(17).Select
Selection.NumberFormat = "0.00"
Columns(18).Select
Selection.NumberFormat = "0.00"
Columns(20).Select
Selection.NumberFormat = "0.00"
Columns(21).Select
Selection.NumberFormat = "0.00"
Columns(22).Select
Selection.NumberFormat = "0.00"
' Debug.Print Cells(10, 2)
lrow = Cells(Rows.Count, "C").End(xlUp).row
'debig.Print Cells(2, 9).Value
Dim i As Integer
For i = 5 To lrow
' calculating the UM = NS - CoS
'for SDP3
If (Cells(i, 8).Value = "Missing Data" Or Cells(i, 9).Value = "Missing Data") Then
Cells(i, 10).Value = "Missing Data"
Else
Cells(i, 10).Value = Cells(i, 8).Value - Cells(i, 9).Value
End If
'TG2
If (Cells(i, 12).Value = "Missing Data" Or Cells(i, 13).Value = "Missing Data") Then
Cells(i, 14).Value = "Missing Data"
Else
Cells(i, 14).Value = Cells(i, 12).Value - Cells(i, 13).Value
End If
' PTD
If (Cells(i, 16).Value = "Missing Data" Or Cells(i, 17).Value = "Missing Data") Then
Cells(i, 18).Value = "Missing Data"
Else
Cells(i, 18).Value = Cells(i, 16).Value - Cells(i, 17).Value
End If
' PTE
If (Cells(i, 20).Value = "Missing Data" Or Cells(i, 21).Value = "Missing Data") Then
Cells(i, 22).Value = "Missing Data"
Else
Cells(i, 22).Value = Cells(i, 20).Value - Cells(i, 21).Value
End If
'%UM DEVIATION = UM% of the second - UM%
'SDP3 --- TG2
If (Cells(i, "K").Value = "N/A" Or Cells(i, "O").Value = "N/A") Then
Cells(i, "Y").Value = "N/A"
Else
Cells(i, "Y").Value = Cells(i, "O").Value - Cells(i, "K").Value
End If
'SDP3 --- PTE
If (Cells(i, "K").Value = "N/A" Or Cells(i, "S").Value = "N/A") Then
Cells(i, "AB").Value = "N/A"
Else
Cells(i, "AB").Value = Cells(i, "S").Value - Cells(i, "K").Value
End If
'TG2 -- PTE
If (Cells(i, "O").Value = "N/A" Or Cells(i, "S").Value = "N/A") Then
Cells(i, "AE").Value = "N/A"
Else
Cells(i, "AE").Value = Cells(i, "S").Value - Cells(i, "O").Value
End If
' DEV MSEK if (UM% of both < 0 -> %UM * NS of the second)
'SDP3 --- TG2
If (Cells(i, "Y").Value = "N/A" Or Cells(i, "L").Value = "N/A") Then
Cells(i, "X").Value = "N/A"
Else
If (Cells(i, "Y").Value < 0) Then
Cells(i, "X").Value = 0
Else
Cells(i, "X").Value = Cells(i, "Y").Value * Cells(i, "L").Value
End If
End If
'SDP3 --- PTE
If (Cells(i, "AB").Value = "N/A" Or Cells(i, "P").Value = "N/A") Then
Cells(i, "AA").Value = "N/A"
Else
If (Cells(i, "AB").Value < 0) Then
Cells(i, "AA").Value = 0
Else
Cells(i, "AA").Value = Cells(i, "AB").Value * Cells(i, "P").Value
End If
End If
'TG2 -- PTE
If (Cells(i, "AE").Value = "N/A" Or Cells(i, "P").Value = "N/A") Then
Cells(i, "AD").Value = "N/A"
Else
If (Cells(i, "AE").Value < 0) Then
Cells(i, "AD").Value = 0
Else
Cells(i, "AD").Value = Cells(i, "AE").Value * Cells(i, "P").Value
End If
End If
' indicators Y,AB,AE - > Z, AC , AF
If (Cells(i, "Y").Value = "N/A") Then
Cells(i, "Z").Value = "N/A"
Else
If (Cells(i, "Y").Value < 0) Then
Cells(i, "Z").Value = Chr(226)
Cells(i, "Z").Font.Name = "Wingdings"
Cells(i, "Z").Font.Color = vbRed
ElseIf (Cells(i, "Y").Value > 0) Then
Cells(i, "Z").Value = Chr(225)
Cells(i, "Z").Font.Name = "Wingdings"
Cells(i, "Z").Font.Color = vbGreen
Else
Cells(i, "Z").Value = "-"
End If
End If
If (Cells(i, "AB").Value = "N/A") Then
Cells(i, "AC").Value = "N/A"
Else
If (Cells(i, "AB").Value < 0) Then
Cells(i, "AC").Value = Chr(226)
Cells(i, "AC").Font.Name = "Wingdings"
Cells(i, "AC").Font.Color = vbRed
ElseIf (Cells(i, "AB").Value > 0) Then
Cells(i, "AC").Value = Chr(225)
Cells(i, "AC").Font.Name = "Wingdings"
Cells(i, "AC").Font.Color = vbGreen
Else
Cells(i, "AC").Value = "-"
End If
End If
If (Cells(i, "AE").Value = "N/A") Then
Cells(i, "AF").Value = "N/A"
Else
If (Cells(i, "AE").Value < 0) Then
Cells(i, "AF").Value = Chr(226)
Cells(i, "AF").Font.Name = "Wingdings"
Cells(i, "AF").Font.Color = vbRed
ElseIf (Cells(i, "AE").Value > 0) Then
Cells(i, "AF").Value = Chr(225)
Cells(i, "AF").Font.Name = "Wingdings"
Cells(i, "AF").Font.Color = vbGreen
Else
Cells(i, "AF").Value = "-"
End If
End If
Next
' format the columns
Columns("Y:Y").Select
Selection.NumberFormat = "0.00%"
Columns("AB:AB").Select
Selection.NumberFormat = "0.00%"
Columns("AE:AE").Select
Selection.NumberFormat = "0.00%"
ActiveSheet.Range("A5:AF" & lrow).Copy
ThisWorkbook.Worksheets("final").Activate
Application.Wait (Now + TimeValue("0:00:01"))
lrowFinal = Cells(Rows.Count, "C").End(xlUp).row
If lrowFinal < 4 Then
lrowFinal = 4
End If
ThisWorkbook.Sheets("final").Range("C3:AH" & lrowFinal).ClearContents
ThisWorkbook.Sheets("final").Range("C4").PasteSpecial (Excel.XlPasteType.xlPasteAll)
'ActiveSheet.PasteSpecial Paste:=xlPasteValues
'PasteAsLocalFormula
Application.CutCopyMode = False
With ActiveSheet
.AutoFilterMode = False
.Range("C4").CurrentRegion.AutoFilter
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
the error happens a few lines at the end at:
ThisWorkbook.Sheets("final").Range("C4").PasteSpecial (Excel.XlPasteType.xlPasteAll)
what did I do wrong, I tried many fixes but none worked
EDIT:
I changed the copying code to the following but I am still getting the error:
ThisWorkbook.Sheets("final").Activate
Application.Wait (Now + TimeValue("0:00:01"))
lrowFinal = Cells(Rows.Count, "C").End(xlUp).row
If lrowFinal < 4 Then
lrowFinal = 4
End If
ActiveSheet.Range("C3:AH" & lrowFinal).ClearContents
Sheets("temporary").Activate
ActiveSheet.Range("A5:AF" & lrow).Copy
ThisWorkbook.Worksheets("final").Activate
ActiveSheet.Range("C4").PasteSpecial xlPasteAll

Replace range of data if target value already exists

The following script selects a range of data on one sheet and transfers the selection to another sheet.
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 6 To LastRow
If Cells(i, 1) <> "" And Cells(i, 21) = "OK" And Cells(i, 22) <> "Yes" Then
Range(Cells(i, 1), Cells(i, 4)).Select
Selection.Copy
erow = Worksheets("iForms").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Worksheets("iForms").Cells(erow, 1).PasteSpecial Paste:=xlPasteValues
If Cells(i, 1) <> "" Then Cells(i, 22).Value = "Yes"
If Cells(i, 22) <> "" Then Cells(i, 23).Value = Now
If Cells(i, 23) <> "" Then Cells(i, 24).Value = Environ("UserName")
ActiveWorkbook.Save
End If
Next i
I would now like to introduce a script which will replace the row of data on the target sheet if the value in column A already exists, but i'm not sure how to achieve this, any help is much appreciated.
Thank you in advance.
Public Function IsIn(li, Val) As Boolean
IsIn = False
Dim c
For Each c In li
If c = Val Then
IsIn = True
Exit Function
End If
Next c
End Function
dim a: a= range(destWB.sheet(whatever)..range("A1"),destWB.Range("A" & destWB.sheet(whatever).Rows.Count).End(xlUp)).value
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 6 To LastRow
if isin(a, Cells(i, 1) ) then
do whatever you want
else
If Cells(i, 1) <> "" And Cells(i, 21) = "OK" And Cells(i, 22) <> "Yes" Then
Range(Cells(i, 1), Cells(i, 4)).Select
Selection.Copy
erow = Worksheets("iForms").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Worksheets("iForms").Cells(erow, 1).PasteSpecial Paste:=xlPasteValues
If Cells(i, 1) <> "" Then Cells(i, 22).Value = "Yes"
If Cells(i, 22) <> "" Then Cells(i, 23).Value = Now
If Cells(i, 23) <> "" Then Cells(i, 24).Value = Environ("UserName")
ActiveWorkbook.save
End If
End If
Next i
I suggest using a Dictionary-Object which is most likely a Hash-Map. The advantage is that you can use the built in method Dictionary.Exists(Key) to check if the Dictionary already holds the specified value (Key).
Also you should not save the Workbook in every step of the iteration. It would be better (and faster) to only save the workbook after completing the copying of your whole data.
Additionally your If-Tests after copy-paste are not neccessary, because you are already checking for Cells(i,1)<>"" before copying so you don't have to check this again as it does not change.
The following code shows how to get your desired result:
Set dict = CreateObject("Scripting.Dictionary")
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 6 To LastRow
If Cells(i, 1) <> "" And Cells(i, 21) = "OK" And Cells(i, 22) <> "Yes" Then
If dict.Exists(Cells(i,1).Value) Then
'value already exists -> update row number
dict.Item(Cells(i,1).Value)=i
Else
'save value of column A and row number in dictionary
dict.Add Cells(i,1).Value, i
End If
Cells(i, 22).Value = "Yes"
Cells(i, 23).Value = Now
Cells(i, 24).Value = Environ("UserName")
End If
Next i
'finally copy over your data (only unique values)
For Each i In dict.Items
Range(Cells(i, 1), Cells(i, 4)).Select
Selection.Copy
erow = Worksheets("iForms").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Worksheets("iForms").Cells(erow, 1).PasteSpecial Paste:=xlPasteValues
Next i

How to Optimize Excel VBA Formula

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..
I'd go retrieving import workbook data sheets data into arrays, thus minimizing import data workbook opening time, and releasing it as soon as possible.
moreover your code has a lot of repetitions and other possible improvements
here follows a possible refactoring of your code to cope with the "data to array" issue and avoiding repetitions:
Sub T1CopyDataFromAnotherFileIfSearchTextIsFound()
Dim Names As Variant ' <--| array that will hold all the "names"
Dim Months6_9 As Variant, Months10_24 As Variant, Months25_36 As Variant ' <--| arrays that will store ImportFile worksheets data
Dim strPath As String, strImportFile As String, strSearchString As String
ClearSheets '<--|'Clear Existing Content
SetNames Names '<--| set the "names"
'Team 1 Content Copy >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
strPath = ThisWorkbook.Path
strImportFile = "Book1.xlsx"
On Error GoTo Errorhandler '<---| where is the label???
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
' here try and read data from import workbook to arrays Months6_9, Months10_24, and Months25_36
If Not ReadImportData(strPath & "\" & strImportFile, Months6_9, Months10_24, Months25_36) Then Exit Sub '<--| exit if reading data unsuccessfully
'Account1>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
' what was here has been shifted to
'Account4>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
strSearchString = Names(4)
Account Months6_9, Months10_24, Months25_36, ThisWorkbook.Worksheets("4"), strSearchString
'Account5>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
strSearchString = Names(5)
Account Months6_9, Months10_24, Months25_36, ThisWorkbook.Worksheets("5"), strSearchString
'Account6>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
strSearchString = Names(6)
Account Months6_9, Months10_24, Months25_36, ThisWorkbook.Worksheets("6"), strSearchString
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
which relies on the following helper subs/functions:
The function that reads import workbook worksheets data and stores them into arrays
Function ReadImportData(wbFullName As String, Months6_9 As Variant, Months10_24 As Variant, Months25_36 As Variant) As Boolean
Dim wbkImportFile As Workbook
If Dir(wbFullName) = "" Then Exit Function '<--| exit if there's no such file
On Error Resume Next
Set wbkImportFile = Workbooks.Open(Filename:=wbFullName, ReadOnly:=True, UpdateLinks:=False)
On Error GoTo 0
If wbkImportFile Is Nothing Then Exit Function '<--| exit if you couldn't open the workbook
With wbkImportFile
With .Worksheets("6-9 Months")
.Columns("L:M").Insert
Months6_9 = .Range("A2:R" & .Cells(.Rows.Count, "K").End(xlUp).Row).Value
End With
With .Worksheets("10-24 Months")
Months10_24 = .Range("A2:R" & .Cells(.Rows.Count, "K").End(xlUp).Row).Value
End With
With .Worksheets("25-36 Months")
Months25_36 = .Range("A2:R" & .Cells(.Rows.Count, "K").End(xlUp).Row).Value
End With
End With
wbkImportFile.Close SaveChanges:=False
ReadImportData = True
End Function
the sub the process the single Account
Sub Account(Months6_9 As Variant, Months10_24 As Variant, Months25_36 As Variant, shtThisSheet As Worksheet, strSearchString As String)
PutHeaders shtThisSheet '<--| put headers in passed sheet
ProcessMonths Months6_9, shtThisSheet, strSearchString '<-- process Months6_9 arrayfor passed strSearchString
ProcessMonths Months10_24, shtThisSheet, strSearchString '<-- process Months10_24 array for passed strSearchString
ProcessMonths Months25_36, shtThisSheet, strSearchString '<-- process Months25_36 array for passed strSearchString
End Sub
which on is turn demands the processing of single months-interval to:
Sub ProcessMonths(Months As Variant, shtThisSheet As Worksheet, strSearchString As String)
Dim nRows As Long, nCols As Long, iRow As Long, jCol As Long
nRows = UBound(Months, 1)
nCols = UBound(Months, 2)
ReDim tempArr(1 To nCols) As Variant
With shtThisSheet
For iRow = 1 To nRows
If InStr(1, Months(iRow, 11), strSearchString, vbTextCompare) > 0 Then
For jCol = 1 To nCols
tempArr(jCol) = Months(iRow, jCol)
Next jCol
.Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Row + 1).Resize(, nCols).Value = tempArr
End If
Next iRow
End With
End Sub
and then the last ones
Sub PutHeaders(shtThisSheet As Worksheet)
shtThisSheet.Range("A1:R1") = Array("memberid", "firstname", "lastname", "country", "ADT", "Team", _
"Lastgamingdt", "Type", "predom", "playStatus", "HostName", "HostLogin", _
"Campaign", "GamingOfferType", "OfferAmount", "Tagcode", "TagcodeDescription", "Comments")
End Sub
Sub ClearSheets()
Dim i As Long
With ThisWorkbook
For i = 4 To 23
.Sheets(CStr(i)).Cells.ClearContents
Next i
End With
End Sub
Sub SetNames(Names As Variant)
With ThisWorkbook.Sheets("UserAccessAcc")
Names = Application.Transpose(.Range("B5:B25").Value)
Names(1) = .Range("B3").Value
End With
End Sub