Find Copy and Paste in VBA macro - vba

I am trying to write a macro which search data from one sheet and copy's to another.
But now I have a problem because I want to copy data between two searches and paste the whole data from multiple cells into one single cell.
For example in the above picture my macro:
SEARCH for "--------------" and "*****END OF RECORD"
COPIES everything in between , here example data in row 29 and 30 and from column A,B,C
PASTE all the data from multiple cells A29,B29,C29 and then A30,B30,C30 to single cell in sheet 2 say cell E2.
This pattern is reoccurring in the column A so I want to search for the next occurrence and do all the steps 1,2,3 and this time I will paste it in Sheet2 , cell E3.
Below is the code:
I am able to search my pattern but hard time in giving references to the cells in between those searched patterns and then copying all the data to ONE cell.
x = 2: y = 2: Z = 7000: m = 0: n = 0
Do
x = x + 1
If ThisWorkbook.Sheets("lic").Range("A" & x) = "---------------------" Then m = x
If ThisWorkbook.Sheets("lic").Range("A" & x) = "****** END OF RECORD" Then n = x
If (n > 0) Then
Do
For i = m To n
ThisWorkbook.Sheets("lic").Range("A" & i + 1).Copy
ThisWorkbook.Sheets("lic").Range("B" & i + 1).Copy
ThisWorkbook.Sheets("lic").Range("C" & i + 1).Copy
'If (n > 0) Then ThisWorkbook.Sheets("Sheet1").Range("E" & y) = ThisWorkbook.Sheets("lic").Range("A" & m + 1, "C" & n - 1): y = y + 1
'If (n > 0) Then ThisWorkbook.Sheets("Sheet1").Range("E" & y).Resize(CopyFrom.Rows.Count).Value = CopyFrom.Value: y = y + 1
Loop While Not x > Z
'Driver's Licence #:Driver's Licence #:Driver's Licence #:
x = 2: y = 2: Z = 7000: counter = 1
Do
x = x + 1
If ThisWorkbook.Sheets("lic").Range("A" & x) = "Driver's Licence #:" Then counter = counter + 1
If (counter = 2) Then ThisWorkbook.Sheets("Sheet1").Range("B" & y) = ThisWorkbook.Sheets("lic").Range("C" & x): y = y + 1: counter = 0
If x = Z Then Exit Sub
Loop
End Sub

Considering that the search is working correctly, about the copy thing you just need to do:
Sheet2.Range("E2").value = ThisWorkbook.Sheets("lic").Range("A" & i + 1).value & ";" & ThisWorkbook.Sheets("lic").Range("B" & i + 1).value & ";" & ThisWorkbook.Sheets("lic").Range("C" & i + 1).value
The result will be something like: AIR COO; L DAT; A
--------UPDATE---------
It was hard to understand your code, so I'm write a new one. Basically it's copy what it found on sheet1 to sheet2.
Sub Copy()
Dim count As Integer 'Counter of loops to the for
Dim Z As Integer 'Limit of (?)
Dim h As Integer 'Count the filled cells on sheet2
Dim y As Integer 'Counter the columns to be copied
Z = 7000
h = 1
'Assuming that the "----" will always be on the top, the code will start searching on the second row
'if it's not true, will be needed to validate this to.
For count = 2 To Z
If Sheet1.Cells(count, 1).Value <> "****** END OF RECORD" Then
If Sheet1.Cells(count, 1).Value <> "" Then
For y = 1 To 3 'In case you need to copy more columns just adjust this for.
Sheet2.Cells(h, 1).Value = Sheet2.Cells(h, 1).Value & Sheet1.Cells(count, y).Value
Next y
h = h + 1
End If
Else
MsgBox "END OF RECORD REACHED"
Exit Sub
End If
Next count
End Sub
Maybe I don't get the full idea but this might work for you.

I'm not at all sure what you want to see in the final output, so this is an educated guess:
Sub DenseCopyPasteFill ()
Dim wsFrom, wsTo As Worksheet
Dim ur As Range
Dim row, newRow As Integer
Dim dataOn As Boolean
Dim currentVal As String
dataOn = False
newRow = 3
Set wsFrom = Sheets("Sheet1")
Set wsTo = Sheets("Sheet2")
Set ur = wsFrom.UsedRange
For row = 1 To ur.Rows.Count
If wsFrom.Cells(row, 1).Value2 = "--------------" Then
dataOn = True
ElseIf wsFrom.Cells(row, 1).Value2 = "***** END OF RECORD" Then
newRow = newRow + 1
dataOn = False
ElseIf dataOn Then
currentVal = wsTo.Cells(newRow, 5).Value2
wsTo.Cells(newRow, 5).Value2 = currentVal & _
wsFrom.Cells(row, 1) & wsFrom.Cells(row, 2) & _
wsFrom.Cells(row, 3)
End If
Next row
End Sub
If you can get away without using the Windows clipboard, I would. Instead of copy/paste, here I demonstrated how you can simply add or append a value.

Add this sub:
Sub copy_range(rng As Range)
Dim str As String
str = rng.Cells(1).Value & rng.Cells(2).Value & rng.Cells(3).Value
Range("E" & Range("E" & Rows.Count).End(xlUp).Row + 1).Value = str
End Sub
Then your for loop should look like this:
For i = m To n
copy_range ThisWorkbook.Sheets("lic").Range("A" & i + 1 & ":C" & i + 1)
Next i

Related

Macro to compare and highlight case-sensitive data

I came across a macro that compares data pasted in column B with column A and highlights column B if not an Exact match with column A.
Sub HighlightNoMatch()
Dim r As Long
Dim m As Long
m = Range("B" & Rows.Count).End(xlUp).Row
Range("B1:B" & m).Interior.ColorIndex = xlColorIndexNone
For r = 1 To m
If Evaluate("ISERROR(MATCH(TRUE,EXACT(B" & r & ",$A$1:$A$30),0))") Then
Range("B" & r).Interior.Color = vbRed
End If
Next r
End Sub
How do I change the code to achieve as below -
I want the code to highlight Column F on sheet2, if it is not an exact match with data in Column B on sheet1."
Rather than having a fixed range ($A$1:$A$30) I would loop through each value in the range and check for a match:
Sub HighlightNoMatch()
Dim t As Long
Dim m As Long
m = Worksheets("Sheet2").Range("F" & Rows.Count).End(xlUp).Row
t = Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
Worksheets("Sheet2").Range("F1:F" & m).Interior.ColorIndex = xlColorIndexNone
For x1 = 1 To m
For x2 = 1 To t
If Worksheets("Sheet2").Range("F" & x1).Value = Worksheets("Sheet1").Range("B" & x2).Value Then
Exit For
ElseIf Worksheets("Sheet2").Range("F" & x1).Value <> Worksheets("Sheet1").Range("B" & x2).Value And x2 = t Then
Worksheets("Sheet2").Range("F" & x1).Interior.Color = vbRed
End If
Next x2
Next x1
End Sub

Automatically copy rows to sheet based on cell

I have a main sheet titled Task List with a list of rows, and I need each row to be copied to a specific sheet based on the contents of cells in Column I. There are four other sheets (titled Admin, Engine, Lab, and RD) where these values need to be copied to, depending on the value in Column I. Additionally, there is a separate sheet named Completed that where rows should move to (not copy) which contain the word "Complete" in Column E of the sheet titled Task List.
Below is the code that I have currently that I sourced from a post I found. It's not currently copying anything when I run it. Can anyone suggest new code or modifications to this?
Sub copyRows()
Set a = Sheets("Task List")
Set b = Sheets("Admin")
Set c = Sheets("Engine")
Set d = Sheets("Lab")
Set e = Sheets("RD")
Set f = Sheets("Completed")
Dim t
Dim u
Dim v
Dim w
Dim y As Long
Dim z
t = 2
u = 2
v = 2
w = 2
z = 3
Do Until IsEmpty(a.Range("I" & z))
If a.Range("I" & z) = "Admin" Then
t = t + 1
b.Rows(t).Value = a.Rows(z).Value
End If
If a.Range("I" & z) = "Engine" Then
u = u + 1
c.Rows(u).Value = a.Rows(z).Value
End If
If a.Range("I" & z) = "Lab" Then
v = v + 1
d.Rows(v).Value = a.Rows(z).Value
End If
If a.Range("I" & z) = "RD" Then
w = w + 1
e.Rows(w).Value = a.Rows(z).Value
End If
If a.Range("E" & z) = "COMPLETE" Then
y = f.Range("a" & Rows.Count).End(xlUp).Row + 1
f.Rows(y).Value = a.Rows(z).Value
a.Rows(z).Delete
z = z - 1
End If
z = z + 1
Loop
End Sub
I think the loop is not working correctly. Try this code:
Sub copyRows()
Set a = Sheets("Task List")
Set b = Sheets("Admin")
Set c = Sheets("Engine")
Set d = Sheets("Lab")
Set e = Sheets("RD")
Set f = Sheets("Completed")
Dim t, u, v, w, y, CountLng As Long
CountLng = ActiveSheet.UsedRange.Rows.Count
t = 2
u = 2
v = 2
w = 2
z = 3
For z = CountLng to 3 step -1
If a.Range("I" & z) = "Admin" Then
t = t + 1
b.Rows(t).Value = a.Rows(z).Value
ElseIf a.Range("I" & z) = "Engine" Then
u = u + 1
c.Rows(u).Value = a.Rows(z).Value
ElseIf a.Range("I" & z) = "Lab" Then
v = v + 1
d.Rows(v).Value = a.Rows(z).Value
ElseIf a.Range("I" & z) = "RD" Then
w = w + 1
e.Rows(w).Value = a.Rows(z).Value
End If
If a.Range("E" & z) = "COMPLETE" Then
y = f.Range("a" & Rows.Count).End(xlUp).Row + 1
f.Rows(y).Value = a.Rows(z).Value
a.Rows(z).Delete
End If
Next z
End Sub
Try the AutoFilter method, you'll find it shorter, and faster when dealing with large data sets.
Note: modify Set FilterRng = a.Range(a.Range("I3"), a.Range("I3").End(xlDown)) to the columns where your data lies.
Option Explicit
Sub copyRows()
Dim a As Worksheet
Dim SheetNames As Variant, ShtInd As Variant, FilterRng As Range
Dim CopyRng As Range
Set a = Sheets("Task List")
SheetNames = Array("Admin", "Engine", "Lab", "RD", "Completed")
a.Range("I3").AutoFilter ' <-- expand the range where your data lies
Set FilterRng = a.Range(a.Range("I3"), a.Range("I3").End(xlDown))
' loop through all sheet names in array, except "Task List"
For Each ShtInd In SheetNames
' check if there is a match before setting the AutoFilter (not to get an error)
If Not IsError(Application.Match(ShtInd, a.Range(a.Range("I3"), a.Range("I3").End(xlDown)), 0)) Then
FilterRng.AutoFilter Field:=1, Criteria1:=ShtInd ' <-- sut autofilter according to sheet name
Set CopyRng = FilterRng.SpecialCells(xlCellTypeVisible) ' <-- set range to only visible rows
CopyRng.EntireRow.Copy Sheets(ShtInd).Range("A" & Sheets(ShtInd).Cells(Sheets(ShtInd).Rows.Count, "I").End(xlUp).Row + 1) ' <-- Copy >> paste the entire range to all sheets to first empty row
If ShtInd Like "Completed" Then
CopyRng.EntireRow.Delete xlShiftUp ' <-- delete the entire range related to sheet "Completed"
End If
End If
FilterRng.AutoFilter Field:=1 ' <-- reset filter
Next ShtInd
End Sub

Excel Macro Transpose only few columns

I have a excel sheet looks like this: "Sheet1" & "Sheet2" and I wanted the result as shown in "Sheet3".
Sample Data
Eventually I would like to put a "Button" in a separate sheet (Control Panel) and when clicking on it I need to combine the data from "Sheet1" and "Sheet2" with the transpose effect as shown in "Sheet3".
How can I automate this using macro since there are ~2000 "rows" in Sheet 1 and ~1000 in Sheet 2. I'm new to macro so hopefully I can make this automated otherwise I'm copying and pasting all of them manually.
Thanks!
It might be helpful to use a function that returns the last row of a worksheet:
Public Function funcLastRow(shtTarget As Worksheet, Optional iColLimit As Integer = -1) As Long
If iColLimit = -1 Then
iColLimit = 256
End If
Dim rowMaxIndex As Long
rowMaxIndex = 0
Dim ctrCols As Integer
For ctrCols = 1 To iColLimit
If shtTarget.Cells(1048576, ctrCols).End(xlUp).Row > rowMaxIndex Then
rowMaxIndex = shtTarget.Cells(1048576, ctrCols).End(xlUp).Row
End If
Next ctrCols
funcLastRow = rowMaxIndex
End Function
You could use it simply like so:
Dim lLastRow As Long
lLastRow = funcLastRow(Sheets(1))
Please let us know if that worked for you thanks
Here is an all formula solution (No Macro)
Data is in Sheet1 A to I and Sheet2 A to G
I am assuming you have only 6 departments. although if you have additional, the formulas need very little or may be no modification.
In Sheet 3
Get the userID repeated six times
A2 = INDEX(Sheet1!A:A,1+QUOTIENT(ROW()-ROW($A$2)+6,6))
Get Name, Gender & Country
B2 = VLOOKUP($A2,Sheet1!$A$2:$I$3000,COLUMNS($A$1:B$1),FALSE)
C2 = VLOOKUP($A2,Sheet1!$A$2:$I$3000,COLUMNS($A$1:C$1),FALSE)
D2 = VLOOKUP($A2,Sheet1!$A$2:$I$3000,COLUMNS($A$1:D$1),FALSE)
Get Access to department. The "" & ... is to avoid 0 in case the resulting cell was blank.
E2 = "" & IF(SUMPRODUCT(--(Sheet1!$A$1:$I$1=F2))>0,HLOOKUP(F2,Sheet1!$A$1:$I$3000,MATCH(A2,Sheet1!$A$1:$A$3000,0),FALSE),HLOOKUP(F2,Sheet2!$A$1:$G$3000,MATCH(A2,Sheet2!$A$1:$A$3000,0),FALSE))
F2:F7 the departments are Input manually (no formula). F8 is linked to F2 so that the depts repeat when dragged down
G2 = "" & IF(SUMPRODUCT(--(Sheet1!$A$1:$I$1=F2))>0,INDEX(Sheet1!$I$1:$I$3000,MATCH(A2,Sheet1!$A$1:$A$3000,0)),INDEX(Sheet2!$G$1:$G$3000,MATCH(A2,Sheet1!$A$1:$A$3000,0)))
If you need, I can prepare a google sheet to demo. Cheers.
This code works very well for Transpose and concatenate of big data.
Sub ConcatData()
Dim X As Double
Dim DataArray(5000, 2) As Variant
Dim NbrFound As Double
Dim Y As Double
Dim Found As Integer
Dim NewWks As Worksheet
Cells(1, 1).Select
Let X = ActiveCell.Row
Do While True
If Len(Cells(X, 1).Value) = Empty Then
Exit Do
End If
If NbrFound = 0 Then
NbrFound = 1
DataArray(1, 1) = Cells(X, 1)
DataArray(1, 2) = Cells(X, 2)
Else
For Y = 1 To NbrFound
Found = 0
If DataArray(Y, 1) = Cells(X, 1).Value Then
DataArray(Y, 2) = DataArray(Y, 2) & ", " & Cells(X, 2)
Found = 1
Exit For
End If
Next
If Found = 0 Then
NbrFound = NbrFound + 1
DataArray(NbrFound, 1) = Cells(X, 1).Value
DataArray(NbrFound, 2) = Cells(X, 2).Value
End If
End If
X = X + 1
Loop
Set NewWks = Worksheets.Add
NewWks.Name = "SummarizedData"
Cells(1, 1).Value = "Names"
Cells(1, 2).Value = "Results"
X = 2
For Y = 1 To NbrFound
Cells(X, 1).Value = DataArray(Y, 1)
Cells(X, 2).Value = DataArray(Y, 2)
X = X + 1
Next
Beep
MsgBox ("Summary is done!")
End Sub

Evaluate and Store Complex Expression in Excel VBA

I am working on an accounting VBA program that will post Journal entries to a Ledger, and then generate trial balances (i.e. print out the values on a new sheet following "Bal. " in the Ledger). To do this, I need a way to assign the numerical part of the balance cells to a variable or collection. Unfortunately, when I use Debug.Print I see the only value stored is 0 (I am testing just with Common Stock). My expression is: y = Application.Evaluate("=SUM(R[-" & x & "]C:R[-1]C)-SUM(R[-" & x & "]C[1]:R[-1]C[1])") where y represents the balance of Common Stock. How do I properly store the balance value in a variable?
' TODO BE ABLE TO RUN MULTIPLE TIMES
' CHECK FOR POSTED MARK & START WRITING WHEN
' r = "one of the keys", or just creates new Ledger Worksheet every time
Sub MacCompileData()
Application.ScreenUpdating = False
Dim lastRow As Long, x As Long
Dim data, Key
Dim r As Range
Dim cLedger As Collection, cList As Collection
Set cLedger = New Collection
With Worksheets("Journal")
lastRow = .Range("B" & .Rows.Count).End(xlUp).Row
For x = 2 To lastRow
Key = Trim(.Cells(x, 2))
On Error Resume Next
Set cList = cLedger(Key)
If Err.Number <> 0 Then
Set cList = New Collection
cLedger.Add cList, Key
End If
On Error GoTo 0
cLedger(Key).Add Array(.Cells(x, 1).Value, .Cells(x, 3).Value, .Cells(x, 4).Value)
Worksheets("Journal").Cells(x, 5).Value = ChrW(&H2713)
Next
End With
With Worksheets("Ledger")
Dim IsLiability As Boolean
Dim y As Integer
For Each r In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
If r <> "" Then
On Error Resume Next
Key = Trim(r.Text)
If Key = "LIABILITIES" Then
IsLiability = True
End If
data = getLedgerArray(cLedger(Key))
If Err.Number = 0 Then
Set list = cLedger(Key)
x = cLedger(Key).Count
With r.Offset(2).Resize(x, 3)
.Insert Shift:=xlDown, CopyOrigin:=r.Offset(1)
.Offset(-x).Value = data
If IsLiability Then
.Offset(0, 2).Resize(1, 1).FormulaR1C1 = "=""Bal. "" & TEXT(SUM(R[-" & x & "]C:R[-1]C)-SUM(R[-" & x & "]C[1]:R[-1]C[1]),""$#,###"")"
' LOOK HERE FOR Y
y = Application.Evaluate("=SUM(R[-" & x & "]C:R[-1]C)-SUM(R[-" & x & "]C[1]:R[-1]C[1])")
Debug.Print "Common Stock Balance Equals "; y
Else
.Offset(0, 1).Resize(1, 1).FormulaR1C1 = "=""Bal. "" & TEXT(SUM(R[-" & x & "]C:R[-1]C)-SUM(R[-" & x & "]C[1]:R[-1]C[1]),""$#,###"")"
End If
r.Offset(1).EntireRow.Delete
End With
End If
On Error GoTo 0
End If
Next
End With
Application.ScreenUpdating = True
End Sub
Function getLedgerArray(c As Collection)
Dim data
Dim x As Long
ReDim data(1 To c.Count, 1 To 3)
For x = 1 To c.Count
data(x, 1) = c(x)(0)
data(x, 2) = c(x)(1)
data(x, 3) = c(x)(2)
Next
getLedgerArray = data
End Function
Here is a solution that I was able to figure out, though I am not sure if it is the most efficient. In line before the formula is set, I set a Range named BalanceCell to the cell where the formula will be written. I then used the Mid Function to get the string number value from the cell (since the length of "Bal. " is always 5 characters) after the formula is put into BalanceCell.
If IsLiability Then
Set BalanceCell = .Offset(0, 2).Resize(1, 1)
BalanceCell.FormulaR1C1 = "=""Bal. "" & TEXT(SUM(R[-" & x & "]C:R[-1]C)-SUM(R[-" & x & "]C[1]:R[-1]C[1]),""$#,###"")"
y = Mid(BalanceCell.Value, 6, Len(BalanceCell.Value))
Debug.Print "Common Stock Balance is "; y

Excel VBA Find value in column, and do math

I have
Column A - with Names
Column B - with Quantities
Column C - Where I want returned Value of Quantity x Cost
Column E - with Names but located in different cells
Column F - with Prices
What I'm trying to achieve is: Take value from A1 and find it in E:E (Lets say we found it in E10), when found take value of B1 and multiply it by Respective value of F10 - and put all this in Column C
And so on for all values in column A
I was trying to do it with Do while and two variables x and y, but for some reason it doesn't find all values only for some rows.
Thank you in Advance.
Sub update_button()
'calculates money value for amazon sku
Dim x, y, z As Integer 'x, y, and z variables function as loop counters
'Loop through added SKU/Prices
For x = 4 To 25000
If Worksheets("Sheet1").Range("H" & x) = "" Then
'Blank row found, exit the loop
Exit For
End If
'Loop through Column E to find the first blank row to add the value from H into
For y = 4 To 25000
If Worksheets("Sheet1").Range("E" & y) = "" Then
'Blank row found, Add SKU and Price
Worksheets("Sheet1").Range("E" & y) = Worksheets("Sheet1").Range("H" & x)
Worksheets("Sheet1").Range("F" & y) = Worksheets("Sheet1").Range("I" & x)
'Blank out Columns H and I to prevent need to do it manually
Worksheets("Sheet1").Range("H" & x) = ""
Worksheets("Sheet1").Range("I" & x) = ""
Exit For
End If
Next y
Next x
'---NOW THIS IS WHERE I HAVE THE PROBLEM
'Get Values
Dim intCumulativePrice As Integer
'Loop through report tab and get SKU
x = 4 'initialize x to the first row of data on the Sheet1 tab
Do While Worksheets("Sheet1").Range("A" & x) <> "" 'Loop through valid SKU's to find price of item
y = 4 'initialize y to the first row of SKUs on the Sheet1 tab
Do While Worksheets("Sheet1").Range("E" & y) <> ""
If Worksheets("Sheet1").Range("E" & x) = Worksheets("Sheet1").Range("A" & y) Then 'Check if current SKU on Sheet1 tab matches the current SKU from SKU list
'Calculates the total
intCumulativePrice = intCumulativePrice + (Worksheets("Sheet1").Range("B" & y) * Worksheets("Sheet1").Range("F" & x))
' Puts Quantity X Price in Column B agains every Cell
Worksheets("Sheet1").Range("C" & y) = (Worksheets("Sheet1").Range("B" & y) * Worksheets("Sheet1").Range("F" & x))
Exit Do
End If
y = y + 1
Loop
x = x + 1
Loop
'Puts Grand total in Column L Cell 4
Worksheets("Sheet1").Range("L4") = intCumulativePrice
'Show messagebox to show that report processing has completed
MsgBox "Report processing has been completed successfully", vbInformation, "Processing Complete!"
End Sub
You can do this with a simple VLOOKUP formula in column C.
=VLOOKUP(A1,E1:F65000,2,FALSE)*B1
You can also use a named range for the data in columns E and F, so you don't have to rely on a fixed address like E1:F65000.
To do this with VBA you should copy the source data to Variant arrays and loop over those. Much faster and IMO easier to read and debug.
Something like this
Sub Demo()
Dim Dat As Variant
Dim PriceList As Range
Dim PriceListNames As Variant
Dim PriceListPrices As Variant
Dim Res As Variant
Dim sh As Worksheet
Dim i As Long
Dim nm As String
Dim nmIdx As Variant
Dim FirstDataRow As Long
FirstDataRow = 4
Set sh = ActiveSheet
With sh
Dat = Range(.Cells(FirstDataRow, "B"), .Cells(.Rows.Count, "A").End(xlUp))
Set PriceList = Range(.Cells(FirstDataRow, "E"), .Cells(.Rows.Count, "F").End(xlUp))
PriceListNames = Application.Transpose(PriceList.Columns(1)) ' Need a 1D array for Match
PriceListPrices = PriceList.Columns(2)
ReDim Res(1 To UBound(Dat, 1), 1 To 1)
For i = 1 To UBound(Dat, 1)
nm = Dat(i, 1)
nmIdx = Application.Match(nm, PriceListNames, 0)
If Not IsError(nmIdx) Then
Res(i, 1) = Dat(i, 2) * PriceListPrices(nmIdx, 1)
End If
Next
Range(.Cells(FirstDataRow, 3), .Cells(UBound(Dat, 1) + FirstDataRow - 1, 3)) = Res
End With
End Sub
Try this:
Sub HTH()
With Worksheets("Sheet1")
With .Range("A4", .Range("A" & Rows.Count).End(xlUp)).Offset(, 2)
.Formula = "=VLOOKUP(A4,E:F,2,FALSE)*$B$1"
.Value = .Value
End With
End With
End Sub