Unable to copy from a set sheet when looping through data - vba

I had an earlier question which was kindly answered and I was given the following code which worked perfectly in a test environment where the code was looping through 3 sheets with only 1 sheet of data and 3 columns.
Below is my ammended code to go through 16 columns. The issue however I believe I am facing is when opening a sheet in the live environment the sub workbooks all contain 4 tabs which are "Lookup", "Detail", "Summary" and "Calls".
The code contains For Each sheet In ActiveWorkbook.Worksheets
I am wanting to only take the data in the below code from each workbook in the loop in the "Calls" tab. Can anyone recommend any change to the existing loop to do this?
Sub Theloopofloops()
Dim wbk As Workbook
Dim Filename As String
Dim path As String
Dim rCell As Range
Dim rRng As Range
Dim wsO As Worksheet
Dim sheet As Worksheet
Set sheet = ActiveWorkbook.Sheets(Sheet2)
path = "M:\Documents\Call Logger\"
Filename = Dir(path & "*.xlsm")
Set wsO = ThisWorkbook.Sheets("Master")
Do While Len(Filename) > 0
DoEvents
Set wbk = Workbooks.Open(path & Filename, True, True)
For Each sheet In ActiveWorkbook.Worksheets
Set rRng = sheet.Range("A2:A20000")
For Each rCell In rRng.Cells
If rCell <> "" And rCell.Value <> vbNullString And rCell.Value <> 0 Then
wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(1, 0).Value = rCell
wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 1).Value = rCell.Offset(0, 1)
wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 2).Value = rCell.Offset(0, 2)
wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 3).Value = rCell.Offset(0, 3)
wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 4).Value = rCell.Offset(0, 4)
wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 5).Value = rCell.Offset(0, 5)
wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 6).Value = rCell.Offset(0, 6)
wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 7).Value = rCell.Offset(0, 7)
wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 8).Value = rCell.Offset(0, 8)
wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 9).Value = rCell.Offset(0, 9)
wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 10).Value = rCell.Offset(0, 10)
wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 11).Value = rCell.Offset(0, 11)
wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 12).Value = rCell.Offset(0, 12)
wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 13).Value = rCell.Offset(0, 13)
wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 14).Value = rCell.Offset(0, 14)
wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(0, 15).Value = rCell.Offset(0, 15)
End If
Next rCell
Next sheet
wbk.Close False
Filename = Dir
Loop
End Sub

Instead of using the loop, just replace the For Each sheet ... line with
Set sheet = wbk.Worksheets("Calls")
(and remove Next sheet)
You could even shorten that and use
Set rRng = wbk.Worksheets("Calls").Range("A2:A20000")
or even skip that and use
For Each rCell In wbk.Worksheets("Calls").Range("A2:A20000").Cells
You can also shorten the copying by using
wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 16).Value = rCell.Resize(1, 16).Value

you may be after what follows:
Option Explicit
Sub Theloopofloops()
Dim wbk As Workbook
Dim Filename As String
Dim path As String
Dim rCell As Range
Dim wsO As Worksheet
path = "M:\Documents\Call Logger\"
Filename = Dir(path & "*.xlsm")
Set wsO = ThisWorkbook.Sheets("Master")
Do While Len(Filename) > 0
DoEvents
Set wbk = Workbooks.Open(path & Filename, True, True)
For Each rCell In ActiveWorkbook.Worksheets("Calls").Range("A2:A20000")
If rCell <> "" And rCell.Value <> vbNullString And rCell.Value <> 0 Then
wsO.Cells(wsO.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(, 16).Value = rCell.Resize(, 16).Value
End If
Next rCell
wbk.Close False
Filename = Dir
Loop
End Sub

Related

Updating multiple sheets with a userform

I have created a userform which searched a reference number and then populates the userform fields with entries on the line of that reference number in a "Mastersheet". The thing is that reference may actually be on 3 sheets with the same information and what I am wanting to do, is when I update the information pulled onto the userform to update all 3 sheets. Can you please assist?
Private Sub Update_Click()
Dim searchRange As Range
Dim foundCell As Range
Dim mysearch As String
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim ws4 As Worksheet
Set ws1 = Worksheets("MasterData")
Set ws2 = Worksheets("X")
Set ws3 = Worksheets("A")
Set ws4 = Worksheets("C")
mysearch = Me.Search.Value
With ThisWorkbook.Sheets("MasterData")
Set searchRange = .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
End With
Set foundCell = searchRange.Find(what:=mysearch, Lookat:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not foundCell Is Nothing Then
foundCell.Offset(0, 11).Value = Me.RD.Value
foundCell.Offset(0, 17).Value = Me.DD.Value
foundCell.Offset(0, 12).Value = Me.PD.Value
foundCell.Offset(0, 13).Value = Me.NP.Value
foundCell.Offset(0, 14).Value = Me.Brd.Value
foundCell.Offset(0, 15).Value = Me.Com.Value
foundCell.Offset(0, 25).Value = Me.Dt.Value
foundCell.Offset(0, 20).Value = Me.PrGp.Value
foundCell.Offset(0, 21).Value = Me.Iss.Value
foundCell.Offset(0, 7).Value = Me.CVal.Value
foundCell.Offset(0, 22).Value = Me.Un.Value
foundCell.Offset(0, 23).Value = Me.Wt.Value
foundCell.Offset(0, 24).Value = Me.Invd.Value
foundCell.Offset(0, 26).Value = Me.Sh.Value
foundCell.Offset(0, 19).Value = Me.FS.Value
foundCell.Offset(0, 18).Value = Me.LN.Value
foundCell.Offset(0, 16).Value = Me.Add.Value
Else
MsgBox "ID does not exist."
End If
End Sub
Rather than dimming each sheet, what about just creating a collection for them, using a generic worksheet object, and iterating through the collection? see below.
Private Sub Update_Click()
Dim searchRange As Range
Dim foundCell As Range
Dim mysearch As String
Dim ws As Worksheet
Dim sheetCollection As Collection
Set sheetCollection = New Collection
With sheetCollection
.Add Worksheets("MasterData"), Worksheets("MasterData").Name
.Add Worksheets("X"), Worksheets("X").Name
.Add Worksheets("A"), Worksheets("A").Name
.Add Worksheets("C"), Worksheets("C").Name
End With
mysearch = Me.Search.Value
For Each ws In sheetCollection
With ws
Set searchRange = .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
End With
Set foundCell = searchRange.Find(what:=mysearch, Lookat:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not foundCell Is Nothing Then
foundCell.Offset(0, 11).Value = Me.RD.Value
foundCell.Offset(0, 17).Value = Me.DD.Value
foundCell.Offset(0, 12).Value = Me.PD.Value
foundCell.Offset(0, 13).Value = Me.NP.Value
foundCell.Offset(0, 14).Value = Me.Brd.Value
foundCell.Offset(0, 15).Value = Me.Com.Value
foundCell.Offset(0, 25).Value = Me.Dt.Value
foundCell.Offset(0, 20).Value = Me.PrGp.Value
foundCell.Offset(0, 21).Value = Me.Iss.Value
foundCell.Offset(0, 7).Value = Me.CVal.Value
foundCell.Offset(0, 22).Value = Me.Un.Value
foundCell.Offset(0, 23).Value = Me.Wt.Value
foundCell.Offset(0, 24).Value = Me.Invd.Value
foundCell.Offset(0, 26).Value = Me.Sh.Value
foundCell.Offset(0, 19).Value = Me.FS.Value
foundCell.Offset(0, 18).Value = Me.Ln.Value
foundCell.Offset(0, 16).Value = Me.Add.Value
Else
MsgBox "ID(" & mysearch & ") does not exist in " & ws.name
End If
Next ws
End Sub

VBA Code for Identifying if cell contains with loop

So currently I am trying to come up with a if statement. Basically if A3 has any text value I want it to equal awesome. I want to loop this command with the last column in mind.
Sub Criteria
If Range("A2") = "Feedback" And Range("A3") = "**" Then
Range("A1") = "Awesome"
Else
Range("A1") = ""
End If
End sub
(This is the code I came up with can someone help me make it cleaner/faster)
Sub Status()
lastrow = Rows(Rows.Count).End(xlUp).Row
For i = 2 To lastrow
If Cells(i, 1) = "Onsite" And Not IsEmpty(Cells(i, 2)) Then
Cells(i, 3) = "Feedback"
Else
If Cells(i, 1) = "Phone" And Not IsEmpty(Cells(i, 2)) Then
Cells(i, 3) = "Feedback"
Else
If Cells(i, 1) = "Phone" And IsEmpty(Cells(i, 2)) Then
Cells(i, 3) = "Pending Next Step"
Else
If Cells(i, 1) = "Onsite" And IsEmpty(Cells(i, 2)) Then
Cells(i, 3) = "Pending Decision"
End If
End If
End If
End If
Next i
End Sub
Try using Option Explicit also set your worksheet so your not running the code on wrong sheet or to avoid a error
Option Explicit
Public Sub Status()
Dim Sht As Worksheet
Dim rng As Range
Set Sht = ThisWorkbook.Sheets("Sheet1")
For Each rng In Sht.Range("A2", Sht.Range("A9999").End(xlUp))
Debug.Print rng.Address ' print on immed win
DoEvents ' For Debuging
If rng.Value = "Onsite" And rng.Offset(0, 1).Value > 0 Then
rng.Offset(0, 2).Value = "Feedback"
ElseIf rng.Value = "Onsite" And rng.Offset(0, 1).Value = "" Then
rng.Offset(0, 2).Value = "Pending Decision"
End If
If rng.Value = "Phone" And rng.Offset(0, 1).Value > 0 Then
rng.Offset(0, 2).Value = "Feedback"
ElseIf rng.Value = "Phone" And rng.Offset(0, 1).Value = "" Then
rng.Offset(0, 2).Value = "Pending Next Step"
End If
Next
Set Sht = Nothing
Set rng = Nothing
End Sub
Range.Offset Property (Excel)
Syntax: expression.Offset(RowOffset, ColumnOffset)
Returns a Range object that represents a range that?s offset from the specified range.

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

Copy cell values to different Workbook

Firstly, let me apologise if this question has already been answered somewhere else. I had a good look but couldn't find anything that would help me.
Secondly, I'm sure there is a far more simple way to do this but I'm very new the VBA and I'm just trying to teach myself as I go along.
Ok, so I have a sheet at the end of my workbook that compiles information from the previous sheet and I want to copy those values that are all in row 2 to another workbook that we have a network drive.
I've managed to get this to work on the same sheet but not to another workbook (without using a userform).
It comes back with the error 'Invalid Qualifier' for the line
Cells(emptyRow, 1.Value - DateRaised.Value
Here is my code below,
Sub CommandButton1_Click()
Dim emptyRow As Long
Dim DateRaised As Long
Dim CustomerName As String
Dim SiteAddress As String
Dim CallReason As String
Dim CustomerOrderNo As Long
Dim InvoiceNo As Long
Dim CovernoteNo As Long
Dim Findings As String
Dim ProductType As String
Dim Supplier As String
Dim Attempts As Long
Dim Condition As String
Dim DateClosed As Long
Dim CreditGiven As String
Dim CreditValue As Long
Dim IssueDays As Long
Dim Comments As String
DateRaised = Cells(2, "A").Value
CustomerName = Cells(2, "B").Value
SiteAddress = Cells(2, "C").Value
CallReason = Cells(2, "D").Value
CustomerOrderNo = Cells(2, "F").Value
InvoiceNo = Cells(2, "G").Value
CovernoteNo = Cells(2, "H").Value
Findings = Cells(2, "I").Value
ProductType = Cells(2, "J").Value
Supplier = Cells(2, "K").Value
Attempts = Cells(2, "L").Value
Condition = Cells(2, "M").Value
DateClosed = Cells(2, "N").Value
CreditGiven = Cells(2, "O").Value
CreditValue = Cells(2, "P").Value
IssueDays = Cells(2, "Q").Value
Comments = Cells(2, "R").Value
Dim WrkBk As Workbook
Dim WrkSht As Worksheet
Set WrkBk = Workbooks.Open("R:\6024 Onsite\COVER NOTE WORKFLOW\Database\Covernote Databse.xlsx")
Set WrkSht = WrkBk.Sheets("Covernote Database")
WrkSht.Activate
emptyRow = WorksheetFunction.CountA(Range("A:A")) + 1
Cells(emptyRow, 1).Value = DateRaised.Value
Cells(emptyRow, 2).Value = CustomerName.Value
Cells(emptyRow, 3).Value = SiteAddress.Value
Cells(emptyRow, 4).Value = CallReason.Value
Cells(emptyRow, 5).Value = CustomerOrderNo.Value
Cells(emptyRow, 6).Value = InvoiceNo.Value
Cells(emptyRow, 7).Value = CovernoteNo.Value
Cells(emptyRow, 8).Value = Findings.Value
Cells(emptyRow, 9).Value = ProductType.Value
Cells(emptyRow, 10).Value = Supplier.Value
Cells(emptyRow, 11).Value = Attemps.Value
Cells(emptyRow, 12).Value = Condition.Value
Cells(emptyRow, 13).Value = DateClosed.Value
Cells(emptyRow, 14).Value = CreditGiven.Value
Cells(emptyRow, 15).Value = CreditValue.Value
Cells(emptyRow, 16).Value = IssueDays.Value
Cells(emptyRow, 17).Value = Comments.Value
WrkBk.Close (SaveChanges = False)
End Sub
If anyone can point me in the right direction I'd be a very happy man.
it's because you're attempting to treat value types (like String and Long) variables as if they were reference type (objects) ones calling their Value property:
Cells(emptyRow, 1).Value = DateRaised.Value
while you can't (unless you use User Defined Types): value type variables can be only accessed as they are:
Cells(emptyRow, 1).Value = DateRaised
but you can simply code like follows:
Option Explicit
Sub CommandButton1_Click()
Dim emptyRow As Long
Dim curSht As Worksheet
Set curSht = ActiveSheet
With Workbooks.Open("R:\6024 Onsite\COVER NOTE WORKFLOW\Database\Covernote Databse.xlsx").Sheets("Covernote Database")
emptyRow = WorksheetFunction.CountA(.Range("A:A")) + 1
.Cells(emptyRow, 1).Resize(, 17).value = curSht.Cells(2, 1).Resize(, 17).value '<-- paste values from originally opened sheet range A2:Q2
End With
ActiveWorkbook.Close SaveChanges:=False
End Sub

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