I'm trying to update a label while a code executes. Now this works in two other userforms with exact the same code (to update) but in this one he doesn't want to update the info.
The strange thing is, when I execute the code line by line it will update it though. So the name of the labels etc are not wrong.
This is my code:
Dim MSWorkbook As Workbook, MSSheet As Worksheet, GMSheet As Worksheet, i As Integer, LastRow As Integer, LastRowGM As Integer
Dim aantal As Integer, ColNum As Integer
'variabelen toewijzen
Set GMSheet = ThisWorkbook.ActiveSheet
Set MSWorkbook = Workbooks.Open("....")
Set MSSheet = MSWorkbook.ActiveSheet
GMSheet.Activate
ColNum = 72 'letter H
'progress bar opmaken
ParetoPerCategorie.PGB.Max = 11
ParetoPerCategorie.PGB.Min = 0
ParetoPerCategorie.PGB.Value = 1
ParetoPerCategorie.lblInfo.Caption = "Voorbereidend werk"
LastRow = MSSheet.Range("G5").End(xlDown).Row
LastRowGM = GMSheet.Range("A3").End(xlDown).Row
'Data ophalen (per categorie alle 40 getallen optellen en plaatsen in de juiste cel.
For j = 3 To LastRowGM
aantal = 0
ParetoPerCategorie.lblInfo.Caption = "Bezig met categorie " & GMSheet.Range("A" & j).Value
ParetoPerCategorie.lblAantal.Caption = "categorie " & j - 2 & " van de " & LastRowGM - 2
ParetoPerCategorie.PGB.Value = j - 1
Application.Wait (Now + TimeValue("00:00:01"))
For i = LastRow - 40 To LastRow
aantal = aantal + MSSheet.Cells(i, Chr(ColNum)).Value
Next i
GMSheet.Range("B" & j).Value = aantal
ColNum = ColNum + 1
Next j
MSWorkbook.Close False
Unload Me
I have no idea why it doesn't do it when I just run it. Thanks in advance!
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
this question is probably easy to solve but I cannot figure out how to do it and a quick web search didn't lead to anything. So here is my code:
Option Explicit
'Description: This macro is used to number plot all specimens into the stress-strain curve since this has become a task that
'has to be done very frequently
Sub PlotAllSpecimens_Tensile()
Dim ws As Worksheet, wb As Workbook
Dim xrng As Range, yrng As Range, namerng As Range
Dim CH As Chart, CHcond As Chart, CHdry As Chart
Dim Material As String, state As String, Temperatur As String, name As String
Dim i As Integer, j As Integer, idry As Integer, icond As Integer, k As Integer
Dim ser As series
Dim startrow As Integer
Set wb = ActiveWorkbook
idry = 1
icond = 1
For Each CH In wb.Charts
If CH.name = "Stress-Strain curve cond" Then
Set CHcond = CH
ElseIf CH.name = "Stress-Strain curve dry" Then
Set CHdry = CH
End If
Next CH
If Not CHdry Is Nothing Then
For Each ser In CHdry.SeriesCollection
ser.Delete
Next ser
End If
If Not CHcond Is Nothing Then
For Each ser In CHcond.SeriesCollection
ser.Delete
Next ser
End If
For Each ws In wb.Worksheets
If ws.name <> "Start" And ws.name <> "Auswertung" And ws.name <> "Zusammenfassung" Then
i = 1
For k = 1 To 15
If ws.Cells(k, 5 * i - 4) = "Material" Or ws.Cells(k, 5 * i - 4) = "Werkstoff" Then
Material = ws.Cells(k, 5 * i - 3).Value
ElseIf ws.Cells(k, 5 * i - 4) = "Temperatur" Then
Temperatur = ws.Cells(k, 5 * i - 3).Value
ElseIf ws.Cells(k, 5 * i - 4) = "Zustand" Then
state = ws.Cells(k, 5 * i - 3).Value
End If
Next k
While Not IsEmpty(ws.Cells(i * 5 - 4).Value)
name = Material & "_" & i & ", " & state & ", " & Temperatur
Set namerng = ws.Cells(1, 5 * i - 1).End(xlDown).Offset(-1, -1)
namerng.Value = name
startrow = ws.Cells(1, 5 * i - 1).End(xlDown).Row
Set xrng = Range(ws.Cells(startrow, 5 * i - 2), ws.Cells(startrow, 5 * i - 2).End(xlDown))
Set yrng = Range(ws.Cells(startrow, 5 * i - 1), ws.Cells(startrow, 5 * i - 1).End(xlDown))
If Not (CHdry Is Nothing) And state = "dry" Then
CHdry.SeriesCollection.NewSeries
CHdry.SeriesCollection(idry).XValues = xrng
CHdry.SeriesCollection(idry).Values = yrng
CHdry.SeriesCollection(idry).name = ??????????
CHdry.SeriesCollection(idry).Border.ColorIndex = 42 + ws.Index Mod 5
idry = idry + 1
End If
If Not (CHcond Is Nothing) And state = "conditioned" Then
CHcond.SeriesCollection.NewSeries
CHcond.SeriesCollection(icond).XValues = xrng
CHcond.SeriesCollection(icond).Values = yrng
CHcond.SeriesCollection(icond).Border.ColorIndex = 42 + ws.Index Mod 5
CHcond.SeriesCollection(icond).name = ???????
icond = icond + 1
End If
i = i + 1
Wend
End If
Next ws
End Sub
????? marks the issue. I want to name my series the value of the cell "namerng" so if i later change this cell the name in the plot will update. This can be done manually in excel by selecting a cell as the name range. If I use:
CHcond.SeriesCollection(icond).name = namerng.value
The results will be correct but do not change after I change the value of the namerng. So how to I reference the value of one cell as a series name using VBA?
I got it it is:
CHcond.SeriesCollection(icond).name = "='" & ws.name & "'!" & namerng.Address
Not very elegant but it works.
I have an sheet "Result" and I am trying to count the number of "Green", "red" and "" values in the column "K" of my sheet. I am then printing this value In my sheet "status". in sheet status I have a table with column A as week number. So if the weeks in the column A of sheet "status" is the same as the weeknumber in sheet "result" of column O, then I start counting for the values in column K
I have the code working, But I am lost, due to somereason, the count value I receive is not the correct one. For eg "green" I have 73 rows with green in column K of result. but I could see it printed in my sheet "status" as 71.
Could anyone help to figure what is going wrong ?
Sub result()
Dim i As Integer
Dim j As Integer
Dim cnt As Integer
Dim cntu As Integer
Dim sht As Worksheet
Dim totalrows As Long
Set sht = Sheets("Status")
Sheets("Result").Select
totalrows = Range("E5").End(xlDown).Row
n = Worksheets("Result").Range("E5:E" & totalrows).Cells.SpecialCells(xlCellTypeConstants).Count
For i = 2 To WorksheetFunction.Count(sht.Columns(1))
cntT = 0
cntu = 0
cntS = 0
If sht.Range("A" & i) = Val(Format(Now, "WW")) Then Exit For
Next i
For j = 5 To WorksheetFunction.CountA(Columns(17))
If sht.Range("A" & i) = Range("Q" & j) And Range("K" & j) = "Green" Then cntT = cntT + 1
If sht.Range("A" & i) = Range("Q" & j) And Range("K" & j) = "Red" Then cntu = cntu + 1
If sht.Range("A" & i) = Range("Q" & j) And Range("F" & j) = "" Then cntS = cntS + 1
If cntT <> 0 Then sht.Range("C" & i) = cntT
If cntu <> 0 Then sht.Range("D" & i) = cntu
If cntS <> 0 Then sht.Range("B" & i) = cntS
If n <> 0 Then sht.Range("G" & i) = n
Next j
If cntR + cntu <> 0 Then
'sht.Range("D" & i) = cntR / cntu * 100
End If
End Sub
I worked my way through your code and found a irregularities in your loops. Your variables I and j seem to be counting both rows and valid rows. Therefore I renamed these variables to make clear that they are rows. Also, your code tests each row for Red, Green and "". I think it can only be one of these. Therefore, if one is a match the other two can't be. This can lead to double counting. Finally, I found that you seem to be writing the final result to the Status sheet, in the same cells, many, many times.
I'm sorry, the following code isn't tested because I have no data. But I have tried to address the above problems.
Option Explicit
Sub MyResult() ' "Result" is a word reserved for the use of VBA
Dim cntT As Integer, cntU As Integer, cntS As Integer
Dim WsStatus As Worksheet, WsResult As Worksheet
Dim TotalRows As Long
Dim Rs As Integer, Rr As Long ' RowCounters: Status & Result
Dim n As Integer
Set WsStatus = Sheets("Status")
Set WsResult = Sheets("Result")
TotalRows = Range("E5").End(xlDown).Row
n = WsResult.Range("E5:E" & TotalRows).Cells.SpecialCells(xlCellTypeConstants).Count
' Improper counting: Rs is not necessarily aligned with the row number:
' For Rs = 2 To WorksheetFunction.Count(WsStatus.Columns(1))
For Rs = 2 To TotalRows
If WsStatus.Cells(Rs, "A").Value = Val(Format(Now, "WW")) Then Exit For
' If WsStatus.Range("A" & Rs) = Val(Format(Now, "WW")) Then Exit For
Next Rs
' Improper counting: Rr is not necessarily aligned with the row number:
' For Rr = 5 To WorksheetFunction.CountA(Columns(17))
With WsStatus
For Rr = 5 To TotalRows
If (.Cells(Rs, "A").Value = .Cells(Rs, "Q").Value) Then
If (.Cells(Rs, "K").Value = "Green") Then
cntT = cntT + 1
ElseIf (.Cells(Rs, "K").Value = "Red") Then
cntU = cntU + 1
Else
If (.Cells(Rs, "A").Value = "") Then cntS = cntS + 1
End If
End If
Next Rr
End With
With WsResult.Rows(Rs)
' it would be better to write even 0 to these cells
' if you don't want to show 0, format the cell to hide zeroes
.Cells(2).Value = IIf(cntS, cntS, "") ' 2 = B
.Cells(3).Value = IIf(cntT, cntT, "") ' 3 = C
.Cells(4).Value = IIf(cntU, cntU, "") ' 4 = D
.Cells(7).Value = IIf(n, n, "") ' 7 = G
End With
' If cntR + cntU <> 0 Then ' cntR isn't defined
'WsStatus.Range("D" & Rs) = cntR / cntu * 100
End If
End Sub
I urge you to use Option Explicit at the top of your sheet and declare every variable you use.
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'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