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
Related
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 have 2 tables as shown below
Table 1
AA
BB
CC
DD
EE
Table 2
bb
aa
bb1
bb2
cc1
cc2
cc3
I need help to do the below steps using Excel VBA code
Use Table 1 and loop thru each data in table 1 and compare to Table 2
If table 2 only have 1 match, just replace the Table 1 data from the table 2 value on the same row of data from table 1
If have multiple match from table 2, them prompt user to select which data from table 2 need to be written in table 1
Matching Criteria are as follows
AA should match to aa,aa1,aa2,,,,,,
BB shoud match bb,bb1,bb2,,,,,,,,
Below is the code that I have written
Private Sub CommandButton2_Click()
Dim attr1 As Range, data1 As Range
Dim item1, item2, item3, lastRow, lastRow2
Dim UsrInput, UsrInput2 As Variant
Dim Cnt As Integer, LineCnt As Integer
Dim MatchData(1 To 9000) As String
Dim i As Integer, n As Integer, j As Integer, p As Integer
Dim counter1 As Integer, counter2 As Integer
Dim match1(1 To 500) As Integer
Dim matchstr1(1 To 500) As String
Dim tmpstr1(1 To 500) As String
Dim storestr(1 To 500) As String
Dim tmpholderstr As String
counter1 = 1
counter2 = 0
j = 0
p = 0
tmpholderstr = ""
For i = 1 To 500
storestr(i) = ""
Next i
For i = 1 To 500
tmpstr1(i) = ""
Next i
For i = 1 To 500
matchstr1(i) = ""
Next i
For i = 1 To 500
match1(i) = 0
Next i
For i = 1 To 9000
MatchData(i) = ""
Next i
UsrInput = InputBox("Enter Atribute Column")
UsrInput2 = InputBox("Enter Column Alphabet to compare")
With ActiveSheet
lastRow = .Cells(.Rows.Count, UsrInput).End(xlUp).Row
'MsgBox lastRow
End With
With ActiveSheet
lastRow2 = .Cells(.Rows.Count, UsrInput2).End(xlUp).Row
'MsgBox lastRow
End With
Set attr1 = Range(UsrInput & "2:" & UsrInput & lastRow)
Set data1 = Range(UsrInput2 & "2:" & UsrInput2 & lastRow2)
'Debug.Print lastRow
'Debug.Print lastRow2
For Each item1 In attr1
item1.Value = Replace(item1.Value, " ", "")
Next item1
For Each item1 In attr1
If item1.Value = "" Then Exit For
counter1 = counter1 + 1
item1.Value = "*" & item1.Value & "*"
For Each item2 In data1
If item2 = "" Then Exit For
If item2 Like item1.Value Then
counter2 = counter2 + 1
match1(counter2) = counter1
matchstr1(counter2) = item2.Value
tmpstr1(counter2) = item1.Value
Debug.Print item1.Row
Debug.Print "match1[" & counter2; "] = " & match1(counter2)
Debug.Print "matchstr1[" & counter2; "] = " & matchstr1(counter2)
Debug.Print "tmpstr1[" & counter2; "] = " & tmpstr1(counter2)
End If
Next item2
Next item1
' Below is the code that go thru the array and try to write to table 1
' But it is not working as expected.
For n = 1 To 500
If matchstr1(n) = "" Then Exit For
If match1(n) <> match1(n + 1) Then
Range("K" & match1(n)) = matchstr1(n)
Else
i = 0
For j = n To 300
If matchstr1(j) = "" Then Exit For
i = i + 1
If match1(j) = match1(j + 1) Then
tmpstr1(i) = matchstr1(j)
End If
Next j
End If
Next n
End Sub
Try the following. Your two tables are suppose to be in a sheet named "MyData", where there is also a command button (CommandButton2). Add also a UserForm (UserForm1), and in that UserForm add another command button (CommandButton1).
In the module associated with CommandButton2, copy the following code:
Public vMyReplacementArray() As Variant
Public iNumberOfItems As Integer
Public vUsrInput As Variant, vUsrInput2 As Variant
Public lLastRow As Long, lLastRow2 As Long
Public rAttr1 As Range, rData1 As Range, rItem1 As Range, rItem2 As Range
Public iCounter1 As Integer
Sub Button2_Click()
vUsrInput = InputBox("Enter Atribute Column")
vUsrInput2 = InputBox("Enter Column Alphabet to compare")
With ActiveSheet
lLastRow = .Cells(.Rows.Count, vUsrInput).End(xlUp).Row
End With
With ActiveSheet
lLastRow2 = .Cells(.Rows.Count, vUsrInput2).End(xlUp).Row
End With
Set rAttr1 = Range(vUsrInput & "2:" & vUsrInput & lLastRow)
Set rData1 = Range(vUsrInput2 & "2:" & vUsrInput2 & lLastRow2)
ReDim vMyReplacementArray(1 To 1) As Variant
For Each rItem1 In rAttr1
For Each rItem2 In rData1
If (InStr(1, rItem2, rItem1, vbTextCompare)) > 0 Then
vMyReplacementArray(UBound(vMyReplacementArray)) = rItem1.Value & "-" & rItem2.Value
ReDim Preserve vMyReplacementArray(1 To UBound(vMyReplacementArray) + 1) As Variant
End If
Next rItem2
Next rItem1
iNumberOfItems = UBound(vMyReplacementArray) - LBound(vMyReplacementArray)
UserForm1.Show
End Sub
And in the Userform, the following:
Dim k As Integer
Private Sub UserForm_initialize()
Dim myElements() As String
Dim theLabel As Object
Dim rad As Object
Class1 = ""
k = 1
For i = 1 To iNumberOfItems
myElements = Split(vMyReplacementArray(i), "-")
If myElements(0) <> Class1 Then
Set theLabel = UserForm1.Controls.Add("Forms.Label.1", "Test" & i, True)
theLabel.Caption = myElements(0)
theLabel.Left = 80 * k
theLabel.Width = 20
theLabel.Top = 10
k = k + 1
j = 1
End If
Set rad = UserForm1.Controls.Add("Forms.OptionButton.1", "radio" & j, True)
If j = 1 Then
rad.Value = True
End If
rad.Caption = myElements(1)
rad.Left = 80 * (k - 1)
rad.Width = 60
rad.GroupName = k - 1
rad.Top = 50 + 20 * j
j = j + 1
Class1 = myElements(0)
Next i
End Sub
Private Sub CommandButton1_Click()
Dim ctrl As MSForms.Control
Dim dict(5, 1)
Dim i
'## Iterate the controls, and associates the GroupName to the Button.Name that's true.
i = 0
For Each ctrl In Me.Controls
If TypeName(ctrl) = "OptionButton" Then
If ctrl.Value = True Then
dict(i, 0) = ctrl.GroupName
dict(i, 1) = ctrl.Caption
i = i + 1
End If
End If
Next
'For i = 0 To k
'MsgBox "grupo: " & dict(i, 0) & "elem: " & dict(i, 1)
'Next
j = 0
For i = 1 To iNumberOfItems
myElements = Split(vMyReplacementArray(i), "-")
For Each rItem1 In rAttr1
If rItem1 = myElements(0) Then
rItem1 = dict(j, 1)
j = j + 1
End If
Next
Next i
End Sub
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.
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