I keep getting this error called "argument not optional" for the line
If Application.WorksheetFunction.RoundDown(units) = 0 Then
at the "RoundDown" part. I know the code is pretty messy so bear with me, I'm still new to VBA. There are a lot of posts on this, but I still can't seem to correct this error.
Private Sub Command_button1()
Dim buysignal As Range
Dim OHLC As Range
Dim ffdhigh As Range
Dim sellsignal As Range
Dim ffdlow As Range
Dim entryprice As Range
Dim stoploss As Range
Dim exitprice As Range
Dim unitsize As Range
Dim position As Range
Dim n As Range
Dim cll As Range
Dim i As Long
Dim v As Long
Dim units As Long
Dim sl As Long
Dim accv As Long
Dim contsize As Long
Dim risk As Long
Dim lastrow As Long
Dim ts As Double
i = 1
v = 0
units = 0
ts = Range("e3")
sl = Range("o1")
risk = Range("l2")
accv = Range("l1")
contsize = Range("e1")
lastrow = Range("a63").End(xlDown).Rows.Count
For i = 63 To 180
Set OHLC = Range("B" & i & ":" & "E" & i)
Set ffdhigh = Range("I" & i)
Set buysignal = Range("M" & i)
Set cll = Range("B63")
Set sellsignal = Range("N" & i)
Set ffdlow = Range("J" & i)
Set entryprice = Range("p" & i)
Set stoploss = Range("r" & i)
Set n = Range("h" & i)
Set unitsize = Range("t" & i)
units = (risk * accv) / (contsize * n)
For Each cll In OHLC
If cll.Value > (ffdhigh.Value + ts) Then
'(ignore this) And WorksheetFunction.Sum(Worksheets("Sheet2").Range("T" & 63, "T" & 63 + v)) = 0
buysignal.Value = "buy"
ElseIf cll.Value < (ffdlow.Value + ts) Then
sellsignal.Value = "sell"
Else: sellsignal.Value = ""
buysignal = ""
End If
Exit For
Next
If buysignal = "buy" Then
entryprice = ffdlow.Value
stoploss = ffdhigh.Value - (n * sl)
If Application.WorksheetFunction.RoundDown(units) = 0 Then
unitsize = Application.WorksheetFunction.RoundUp(units)
Else: unitsize = Application.WorksheetFunction.RoundDown(units)
End If
ElseIf sellsignal = "sell" Then
entryprice = ffdhigh.Value
stoploss = ffdlow.Value + (n * sl)
Else: entryprice = ""
End If
Next i
End Sub
I don't exactly understand what the optional means, any comments would be much appreciated. Thanks so much guys.
Maybe you could try... giving the number of decimals you need?
unitsize = Application.WorksheetFunction.RoundUp(units, 0)
You need to supply a second argument that specifies the "number of digits". If you set that to 0 you recover rounding to a whole number:
If Application.WorksheetFunction.RoundDown(units, 0) = 0 Then
You need to do the same for RoundUp.
Related
My programm looks for a list of data from Sheets1 into sheets2 or Sheets3 depends on request in sheets1
the programm run properly when the source of research has a range with 2 columns
but with more then 2 columns at the program run only one time at the second time error 13 appears.
please find attached the programm.
thanks for your help
Tarik
Sub Plan_med()
Application.ScreenUpdating = False
Dim i As Long
Dim j As Long
Dim ColumnA As Range
Dim ColumnB As Range
Dim ColumnC As Range
Dim F2 As Range
Dim DernligneA As Long
Dim DernligneB As Long
Dim DernligneC As Long
Dim DernlistA As Long
Dim DernlistB As Long
Dim DernlistC As Long
Dim Dernlist As Long
Dim Dernligne As Long
Dim Medecin As String
Dim Caserne As String
Dim INTERV As String
Dim N As Long
Sheets("Feuil1").Range("L1:Z150").Clear
N = Sheets("Feuil1").Range("D5")
Medecin = Sheets("Feuil1").Range("E5")
Caserne = Sheets("Feuil1").Range("C5")
INTERV = Sheets("Feuil1").Range("B5")
Sheets("Feuil1").Range("D5").Value = N 'inutile car redondant
If Sheets("feuil1").Range("B5") = "ITJ" Then
Fichier = "INT JOUR"
Else: Fichier = "INT NUIT"
End If
DernlistA = Sheets(Fichier).Range("A" & Rows.Count).End(xlUp).Row
DernlistB = Sheets(Fichier).Range("E" & Rows.Count).End(xlUp).Row
DernlistC = Sheets(Fichier).Range("I" & Rows.Count).End(xlUp).Row
DernligneA = Sheets(Fichier).Range("C3").End(xlDown).Rows + 1
DernligneB = Sheets(Fichier).Range("G3").End(xlDown).Rows + 1
DernligneC = Sheets(Fichier).Range("K3").End(xlDown).Rows + 1
If Sheets("feuil1").Range("C5") = "CASERNE 1" Then
Dernlist = DernlistA
Set ColumnA = Sheets(Fichier).Range("A2:C" & DernligneA)
Set F2 = Sheets(Fichier).Range("A1:A" & DernlistA)
Dernligne = DernligneA
End If
If Sheets("feuil1").Range("C5") = "CASERNE 2" Then
Dernlist = DernlistB
Set ColumnA = Sheets(Fichier).Range("E2:G" & DernligneB)
Set F2 = Sheets(Fichier).Range("E1:E" & DernlistB)
Dernligne = DernligneB
End If
If Sheets("feuil1").Range("C5") = "CASERNE 3" Then
Dernlist = DernlistC
Set ColumnA = Sheets(Fichier).Range("I2:K" & DernligneC)
Set F2 = Sheets(Fichier).Range("I1:I" & DernlistC)
Dernligne = DernligneC
End If
j = 1
For i = 2 To Dernligne
If Not IsEmpty(ColumnA.Range("A" & i)) And IsEmpty(ColumnA.Range("C" & i)) Then
ColumnA.Range("A" & i).Copy Sheets("Feuil1").Range("M" & j)
j = j + 1
End If
Next i
Sheets("Feuil1").Range("M1:M" & N).Copy Sheets("Feuil1").Range("K1")
j = 1
For i = 1 To Dernlist
If F2.Range("A" & i) = Sheets("Feuil1").Range("K" & j) Then
F2.Range("C" & i) = "Intervention en cours" & " " & Medecin & " " & Date
j = j + 1
End If
Next i
Application.ScreenUpdating = True
End Sub
I'm working with some legacy code I'd like to build on and I can't seem to figure out the following: Why does the function AantalZichtbareRows return 1? Where It says For Each row In rng.Rows the row count is 1500 something (and so is the actual excel I'm working with).
I'm specifically puzzeled by n = r.Areas.Count. This is where the 1 originates.
Sub motivatieFormOpmaken()
Public iLaatsteKolom As Integer
Public iLaatsteRij As Integer
Public iKolomnrCorpID As Integer
Public iKolomnrNaam As Integer
Public iKolomnrHuidigeFunctie As Integer
Const StBestand = "Stambestand.xlsm"
Const motivatie = "Template motivatieformulier opstapregeling.xlsx"
Dim wbMotivTemp As Workbook
Dim wsMotiv As Worksheet
Dim PathOnly, mot, FileOnly As String
Dim StrPadSourcenaam As String
Set wbMotivTemp = ThisWorkbook
Set wsMotiv = ActiveSheet
StrHoofdDocument = ActiveWorkbook.Name
StrPadHoofdDocument = ActiveWorkbook.Path
StrPadSourcenaam = StrPadHoofdDocument & "\" & c_SourceDump
If Not FileThere(StrPadSourcenaam) Then
MsgBox "Document " & StrPadSourcenaam & " is niet gevonden."
Exit Sub
End If
Application.ScreenUpdating = False
Workbooks.Open FileName:=StrPadSourcenaam
Application.Run "Stambestand.xlsm!unhiderowsandcolumns"
Worksheets("stambestand").Activate
iLaatsteKolom = Worksheets("stambestand").Cells.SpecialCells(xlLastCell).Column
iLaatsteRij = Worksheets("stambestand").Cells.SpecialCells(xlLastCell).row
VulKolomNr
If KolomControle = False Then Exit Sub
Aantalregels = AantalZichtbareRows
Dim rng As Range
Dim row As Range
Dim StrFileName As String
'If Aantalregels > 1 Then
Set rng = Selection.SpecialCells(xlCellTypeVisible)
For Each row In rng.Rows
iRijnummer = row.row
If iRijnummer > 1 Then
wsMotiv.Range("motiv_cid") = Cells(iRijnummer, iKolomnrCorpID).Text
wsMotiv.Range("motiv_naam") = Cells(iRijnummer, iKolomnrNaam).Text
wsMotiv.Range("motiv_ldg") = Cells(iRijnummer, iKolomnrHuidigeLeidingGevende).Text
n = naamOpmaken
wbMotivTemp.Activate
ActiveWorkbook.SaveAs FileName:=StrPadHoofdDocument & "\Docs\" & n & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
End If
Next row
End Sub
Function naamOpmaken() As String
Dim rng As Range
Dim row As Range
Set rng = Selection.SpecialCells(xlCellTypeVisible)
iRijnummer = rng.row
If iRijnummer > 1 Then
naam = Cells(iRijnummer, iKolomnrNaam).Text
ldg = Cells(iRijnummer, iKolomnrHuidigeLeidingGevende).Text
cid = Cells(iRijnummer, iKolomnrCorpID).Text
Dim Position As Long, Length As Long
Dim n As String
Position = InStrRev(naam, " ")
Length = Len(naam)
n = Right(naam, Length - Position)
End If
naamOpmaken = n + "-" + ldg + "-" + cid
End Function
Public Function AantalZichtbareRows() As Integer
Dim rwCt As Long
Dim r As Range
Dim n As Long
Dim I As Long
Set r = Selection.SpecialCells(xlCellTypeVisible)
n = r.Areas.Count
For I = 1 To n
rwCt = rwCt + r.Areas(I).Rows.Count
Next I
AantalZichtbareRows = rwCt
End Function
Range.areas specifies the number of selection areas. Range.Areas
I tested your code and it works as expected. You can have a single selection area containing 1500 rows. Example: "A1:A1500" Or you can have a selection containing 2 areas with three rows each for a total of 6 rows. Example: "A1:A3" and "C4:C6".
This code might help you understand how the method returns information about the selected cells.
Public Function AantalZichtbareRows() As Integer
Dim rwCt As Long
Dim rwCt2 As Long
Dim r As Range
Dim n As Long
Dim I As Long
Set r = Selection.SpecialCells(xlCellTypeVisible)
n = r.Areas.Count
For I = 1 To n
rwCt = rwCt + r.Areas(I).Rows.Count
Next I
Set r = Selection
n = r.Areas.Count
For I = 1 To n
rwCt2 = rwCt2 + r.Areas(I).Rows.Count
Next I
Debug.Print n & " areas selected."
Debug.Print rwCt2 & " rows selected."
Debug.Print rwCt & " visible rows selected."
Debug.Print (rwCt2 - rwCt) & " hidden rows selected."
AantalZichtbareRows = rwCt
End Function
I need to to complete a task for my work. I am new to VBA-Excel so I am kind of stuck. This is also my first post so i am sorry in advance.
As you can see, this is a code I made so that i can get my invoices from a list. There are still some things missing like formatting all of it. But for me the most important part is to combine another worksheet with this code like the same exact code. I need a loop that does me 1st this code and then the second code which is similar.
Something like:
For each ID that is the same of the 2 lists do me a pdf file with all the invoices and all the sums.
The problem is that i get lost in all the coding because i have the feeling my for each statement is getting like 3 pages long which cannot be correct i assume.
My code as is:
Sub Schleife()
Dim Zeile As Long
Dim ZeileMax As Long
Dim n As Long
Dim m As Long
Dim a As Long
Dim strSpalte As String
Dim strSpalte1 As String
Dim strBereich As String
Dim L As Long
Dim R As Long
Dim AR As Range
Dim Le As Long
Dim i As Long
Dim arrBlätter() As String
Dim leereZelle As Long
Dim strSpalte2 As String
Dim strSpalte3 As String
Dim strBereich2 As String
'Worksheets
Dim dl As Worksheet: Set dl = ActiveWorkbook.Sheets("DatenLadevorgänge")
Dim lv As Worksheet: Set lv = ActiveWorkbook.Sheets("Ladevorgänge")
Dim üb As Worksheet: Set üb = ActiveWorkbook.Sheets("Übersicht")
Dim de As Worksheet: Set de = ActiveWorkbook.Sheets("DatenERoaming")
Dim ge As Worksheet: Set ge = ActiveWorkbook.Sheets("Geräte")
Dim ch As Worksheet: Set ch = ActiveWorkbook.Sheets("Chips")
Dim eR As Worksheet: Set eR = ActiveWorkbook.Sheets("eRoaming")
Dim mv As Worksheet: Set mv = ActiveWorkbook.Sheets("MEC-Verträge")
Dim lastrow As Long
Application.ScreenUpdating = True
leereZelle = Columns(11).Find(What:="", Lookat:=xlWhole, Searchdirection:=xlNext).Row
With Tabelle1
If .Cells(leereZelle, 11) = "" Then üb.Cells(1, 1).Value = mv.Cells(leereZelle, 1).Value
End With
lv.Select
lv.Range("A10:O100000").ClearContents
üb.Range("A53:M100000").ClearContents
With dl
ZeileMax = .UsedRange.Rows.Count 'Fkt zur Aufuschung aller SmartCables'
n = 10
For Zeile = 2 To ZeileMax
If .Cells(Zeile, 13).Value = lv.Range("A1").Value Then
.Range(dl.Cells(Zeile, 2), dl.Cells(Zeile, 12)).Copy _
Destination:=lv.Range(lv.Cells(n, 2), lv.Cells(n, 12))
n = n + 1
End If
Next Zeile
lastrow = Cells(Rows.Count, 2).End(xlUp).Row
'Sortieren
.Range("B10:L" & lastrow).Sort Key1:=.Range("B10:B" & lastrow), _
Order1:=xlAscending, Key2:=.Range("C10:C" & lastrow), Order2:=xlAscending
dl.Range("B10", dl.Range(dl.Cells(10, 2), dl.Cells(n, 13))).RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo
End With
L = Range("B65000").End(xlUp).Row
strBereich = "A10:O" & L
strSpalte = "B"
strSpalte1 = "O"
If Range("B10") = "" Then
Cells(10, 2).Value = "Keine Ladevorgänge vorhanden"
Else
lv.Range(strBereich).Sort _
Key1:=Range(strSpalte & "1"), Order1:=xlAscending, Key2:=Range(strSpalte1 & "1"), Order2:=xlAscending, _
Header:=xlNo
lv.Range("I" & L + 1) = WorksheetFunction.Sum(Range("I10:I" & L))
lv.Range("J" & L + 1) = WorksheetFunction.Sum(Range("J10:J" & L))
lv.Range("K" & L + 1) = WorksheetFunction.Sum(Range("K10:K" & L))
lv.Range("L" & L + 1) = WorksheetFunction.Sum(Range("L10:L" & L))
lv.Range("B" & L + 1).Value = "Gesamtsumme"
End If
lv.Range("C1").Value = "$B$2:$L$" & L + 1
üb.Select
With ge
ZeileMax = .UsedRange.Rows.Count
n = 66
For Zeile = 2 To ZeileMax
If ge.Cells(Zeile, 1).Value = üb.Cells(1, 1) Then
.Rows(Zeile).Copy Destination:=üb.Rows(n)
n = n + 1
End If
Next Zeile
End With
R = Range("B65000").End(xlUp).Row
strBereich = "A53:M" & R
strSpalte = "B"
üb.Range(strBereich).Sort Key1:=Range(strSpalte & "1"), Order1:=xlAscending, Header:=xlNo
mv.Select
With mv
.Cells(leereZelle, 11).Value = "ja"
üb.Cells(36, 10).Value = .Cells(leereZelle, 10).Value
End With
End Sub
So I know I asked a very similar question yesterday, its actually about the same code. Former question can be found here.
Its 99% complete, but theres a runtime error in the loop that causes it to fail. What I don't understand is that it runs through once, does everything it needs to, then resetting the range variable YTD causes it to stop at YTD.Formula = YTDs. Code below.
Sub offset(rows1 As Long)
Dim sh As Worksheet
'Integers
Dim i As Long
Dim k As Long
'Movers
Dim current As Range
Dim first As Range
'Metrics
Dim QTRA As Range
Dim YTD As Range
Dim yr1 As Range
Dim yr3 As Range
Dim yr7 As Range
Dim yr5 As Range
Dim yr10 As Range
Dim SI As Range
Dim QTR As Range
Dim YTD_2 As Range
Dim yr1_2 As Range
Dim yr3_2 As Range
Dim yr5_2 As Range
Dim yr7_2 As Range
Dim yr10_2 As Range
Dim SI_2 As Range
'Strings
Dim QTRAs As String
Dim YTDs As String
Dim yr1s As String
Dim yr3s As String
Dim yr7s As String
Dim yr5s As String
Dim yr10s As String
Dim SIs As String
Dim QTRs As String
Dim YTD_2s As String
Dim yr1_2s As String
Dim yr3_2s As String
Dim yr5_2s As String
Dim yr7_2s As String
Dim yr10_2s As String
Dim SI_2s As String
'Puts in the metric names on the top row. Can be adjusted for 2nd row if need be
Sheets("Comparative Performance1").Range("T1").Formula = "YTD"
Sheets("Comparative Performance1").Range("U1").Formula = "yr1"
Sheets("Comparative Performance1").Range("V1").Formula = "yr3"
Sheets("Comparative Performance1").Range("W1").Formula = "yr5"
Sheets("Comparative Performance1").Range("Y1").Formula = "yr7"
Sheets("Comparative Performance1").Range("X1").Formula = "yr10"
Sheets("Comparative Performance1").Range("Z1").Formula = "SI"
Sheets("Comparative Performance1").Range("AA1").Formula = "QTR"
Sheets("Comparative Performance1").Range("AB1").Formula = "YTD_2"
Sheets("Comparative Performance1").Range("AC1").Formula = "yr1"
Sheets("Comparative Performance1").Range("AD1").Formula = "yr3"
Sheets("Comparative Performance1").Range("AE1").Formula = "yr5"
Sheets("Comparative Performance1").Range("AF1").Formula = "yr7"
Sheets("Comparative Performance1").Range("AG1").Formula = "yr10"
Sheets("Comparative Performance1").Range("AH1").Formula = "SI"
'Finds the length of the data
'Dim rn As Range
'Set sh = ThisWorkbook.Sheets("Comparative Performance1")
'Set rn = sh.UsedRange
'k = rn.Rows.Count + rn.Row - 1
k = rows1
For i = 3 To k
'Setting vari ables for each respective data column
Set current = Sheets("Comparative Performance1").Range("J" & i)
Set first = Sheets("Comparative Performance1").Range("B" & i)
Set QTRA = Sheets("Comparative Performance1").Range("S" & i)
Set YTD = Sheets("Comparative Performance1").Range("T" & i)
Set yr1 = Sheets("Comparative Performance1").Range("U" & i)
Set yr3 = Sheets("Comparative Performance1").Range("V" & i)
Set yr5 = Sheets("Comparative Performance1").Range("W" & i)
Set yr7 = Sheets("Comparative Performance1").Range("Y" & i)
Set yr10 = Sheets("Comparative Performance1").Range("X" & i)
Set SI = Sheets("Comparative Performance1").Range("Z" & i)
Set QTR = Sheets("Comparative Performance1").Range("AA" & i)
Set YTD_2 = Sheets("Comparative Performance1").Range("AB" & i)
Set yr1_2 = Sheets("Comparative Performance1").Range("AC" & i)
Set yr3_2 = Sheets("Comparative Performance1").Range("AD" & i)
Set yr5_2 = Sheets("Comparative Performance1").Range("AE" & i)
Set yr7_2 = Sheets("Comparative Performance1").Range("AF" & i)
Set yr10_2 = Sheets("Comparative Performance1").Range("AG" & i)
Set SI_2 = Sheets("Comparative Performance1").Range("AH" & i)
'Moves the benchmarks if it is missing a creation date
If current = "" Then
Range(first, current).Select
Selection.Copy
Range(first, current).offset(-1, 9).Select
ActiveSheet.Paste
'I have it deleting the entire row, which may remove necessary data, not sure yet
rows(i).EntireRow.Delete
End If
'First we have to create strings for all of the formulas using the variable i
YTDs = "=C" + CStr(i) + "-L" + CStr(i)
yr1s = "=D" + CStr(i) + "-M" + CStr(i)
yr3s = "=E" + CStr(i) + "-N" + CStr(i)
yr5s = "=F" + CStr(i) + "-O" + CStr(i)
yr7s = "=G" + CStr(i) + "-P" + CStr(i)
yr10s = "=H" + CStr(i) + "-Q" + CStr(i)
SIs = "=I" + CStr(i) + "-R" + CStr(i)
QTRs = "=S" + CStr(i) + "/B" + CStr(i)
YTD_2s = "=S" + CStr(i) + "/B" + CStr(i)
yr1_2s = "=U" + CStr(i) + "/D" + CStr(i)
yr3_2s = "=V" + CStr(i) + "/E" + CStr(i)
yr5_2s = "=W" + CStr(i) + "/F" + CStr(i)
yr7_2s = "=X" + CStr(i) + "/G" + CStr(i)
yr10_2s = "=Y" + CStr(i) + "/H" + CStr(i)
SI_2s = "=Z" + CStr(i) + "/I" + CStr(i)
'This should assign all of the metrics using the correct variables
YTD.Formula = YTDs ********** THIS IS WHERE IT FAILS ************
yr1.Formula = yr1s
yr3.Formula = yr3s
yr5.Formula = yr5s
yr7.Formula = yr7s
yr10.Formula = yr10s
SI.Formula = SIs
QTR.Formula = QTRs
YTD_2.Formula = YTD_2s
yr1_2.Formula = yr1_2s
yr3_2.Formula = yr3_2s
yr5_2.Formula = yr5_2s
yr7_2.Formula = yr7_2s
yr10_2.Formula = yr10_2s
SI_2.Formula = SI_2s
Next i
End Sub
I think your issue could be within your If statement on the line that says Rows(i).entirerow.delete. You are essentially deleting the Row(i) along with the range assigned to YTD which is equal to Range("T"& i ). You either need to
Delete the row before assigning values to your variables
Add the following after deleting the row:
i=i-1 'this will re-do the row you deleted
Next i 'This will take you back to the top of the look.
Do some error handling that returns you to the top after hitting that error.
You will run into problems if you delete rows within a FOR statement that increments on each pass as you end up with row discrepancies.
The following code may be of use to you...
Sub Offset(Optional rows1 As Long)
Dim sh As Worksheet: Set sh = Sheets("Comparative Performance1")
Dim HeaderRow As Long: HeaderRow = 1
Dim LastRow As Long: LastRow = sh.Cells.Find("*", _
SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
If rows1 > HeaderRow Then LastRow = rows1
Dim i As Long, k As Long, Counter As Long: Counter = 0
With sh
'Puts in the metric names on the top row. Can be adjusted for 2nd row if need be
Dim Headers() As String: Headers = _
Split("YTD,yr1,yr3,yr5,yr7,yr10,SI,QTR,YTD_2,yr1,yr3,yr5,yr7,yr10,SI", ",")
For i = 0 To UBound(Headers)
.Cells(HeaderRow, 20 + i) = Headers(i) 'Starts at Col T
Next i
For i = LastRow To HeaderRow + 2 Step -1
If .Cells(i, 10).Value = "" Then
.Range(.Cells(i, 2), .Cells(i, 10)).Copy
.Range(.Cells(i, 2), .Cells(i, 10)).Offset(-1, 9).PasteSpecial xlPasteValues
.Rows(i).EntireRow.Delete
Counter = Counter + 1
End If
Next i
For i = HeaderRow + 2 To LastRow - Counter
For k = 1 To 7 'Metrics on YTD to SI
.Cells(i, k + 19).FormulaR1C1 = "=RC[-17]-RC[-8]"
.Cells(i, k + 27).FormulaR1C1 = "=RC[-8]/RC[-25]"
Next k
.Cells(i, 27).FormulaR1C1 = "=RC[-8]/RC[-25]" 'Metric on QTR
Next i
End With
End Sub
Oh - I also assume you have an error with the following line:
YTD_2s = "=S" + CStr(i) + "/B" + CStr(i)
Where I guess it should actually be:
YTD_2s = "=T" + CStr(i) + "/C" + CStr(i)
I'm new to using arrays (and VBA in general) and I'm trying to incorporate a series of arrays into a module that formats SPSS syntax output in worksheets in a single workbook. Below is my code, which works, but is duplicating the results that are found. I think it has something to do with the order of my loops but I can't seem to figure out how to fix it. Any thoughts would be greatly appreciated.
Sub FindValues()
Call CreateSummary
'This code will build the initial summary file
Dim ws As Excel.Worksheet
'Application.ScreenUpdating = False
MsgBox ("It will take a moment for data to appear, please be patient if data does not immediately appear")
Dim LastRow As Long
Dim i As Integer
Dim i2 As Integer
Dim x As Integer
Dim y As Integer
Dim CopiedRows As Integer
Dim LocationA(4) As String
Dim LocationB(4) As String
Dim LocationC(4) As String
Dim LocationD(4) As String
Dim VariableA(4) As Integer
Dim VariableB(4) As Integer
Dim ColumnA(4) As String
Dim ColumnB(4) As String
Dim n As Long
'Find DateTime Info
LocationA(1) = "Date_Time"
LocationB(1) = "Quarter"
LocationC(1) = "N"
LocationD(1) = "Minimum"
VariableA(1) = 1
VariableB(1) = 1
ColumnA(1) = "B"
ColumnB(1) = "C"
LocationA(2) = "Dur*"
LocationB(2) = "Methodology_ID"
LocationC(2) = "Mean"
LocationD(2) = "N"
VariableA(2) = 1
VariableB(2) = 1
ColumnA(2) = "C"
ColumnB(2) = "D"
LocationA(3) = "WebTimeout"
LocationB(3) = "Methodology_ID"
LocationC(3) = "Mean"
LocationD(3) = "N"
VariableA(3) = 1
VariableB(3) = 1
ColumnA(3) = "C"
ColumnB(3) = "D"
'LocationA(4) = "Crosstabulation"
'LocationB(4) = "Quarter"
'LocationC(4) = "N"
'LocationD(4) = "Minimum"
'VariableA(4) = 1
'Find OSAT Data
'LocationA(2) = "*Report*"
'LocationB(2) = "*CallMonth*"
'LocationC(2) = "Mean*"
'LocationD(2) = "*Overall*"
'VariableA(2) = 2
For Each ws In Application.ThisWorkbook.Worksheets
'Starting row
i = 1
'Find LastRow
LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
If ws.Name <> "Run Macros" Then
Do While i <= LastRow
For x = 1 To 3
If ws.Range("A" & i).Value Like LocationA(x) And ws.Range("A" & i + 1).Value Like LocationB(x) And ws.Range(ColumnA(x) & i + VariableA(x)).Value Like LocationC(x) And ws.Range(ColumnB(x) & i + VariableB(x)).Value Like LocationD(x) Then
CopiedRows = 0
i2 = i
Do While ws.Range("A" & i2 + 1).Borders(xlEdgeLeft).LineStyle = 1 And ws.Range("A" & i2 + 1).Borders(xlEdgeLeft).Weight = 4
i2 = i2 + 1
CopiedRows = CopiedRows + 1
Loop
n = Sheets("Summary").Cells(Rows.Count, "A").End(xlUp).Row + 4
ws.Rows(i & ":" & i + CopiedRows).Copy Sheets("Summary").Range("A" & n)
On Error Resume Next
End If
Next x
i = i + 1
Loop
End If
Next
'Application.ScreenUpdating = True
End Sub
This works if anyone want to reuse this code...
For x = 1 To 3 Step 1
For Each ws In Application.ThisWorkbook.Worksheets
'Starting row
i = 1
'Find LastRow
LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
Do While i <= LastRow
If ws.Name <> "Run Macros" Or ws.Name <> "Summary" Then
If ws.Range("A" & i).Value Like LocationA(x) And ws.Range("A" & i + 1).Value Like LocationB(x) And ws.Range(ColumnA(x) & i + VariableA(x)).Value Like LocationC(x) And ws.Range(ColumnB(x) & i + VariableB(x)).Value Like LocationD(x) Then
CopiedRows = 0
i2 = i
Do While ws.Range("A" & i2 + 1).Borders(xlEdgeLeft).LineStyle = 1 And ws.Range("A" & i2 + 1).Borders(xlEdgeLeft).Weight = 4
i2 = i2 + 1
CopiedRows = CopiedRows + 1
Loop
n = Sheets("Summary").Cells(Rows.Count, "A").End(xlUp).Row + 4
ws.Rows(i & ":" & i + CopiedRows).Copy Sheets("Summary").Range("A" & n)
Exit For
On Error Resume Next
End If
End If
i = i + 1
Loop
Next
Next x