I need to copy a specific range in multiple sheets and paste them on a final sheet - excel

There are 24 sheets in this workbook. I need to copy the same range from 23 sheets and paste them in a final sheet called "ALL SURVEY". Is there any way to code it in such a way that I don't need to write so much code as I did in the following macro?
Sheets("2").Range("U3:X3").Copy
Sheets("ALL SURVEY").Range("E2").*PasteSpecial xlPasteValues*
Sheets("3").Range("U3:X3").Copy
Sheets("ALL SURVEY").Range("E3").*PasteSpecial xlPasteValues*
Sheets("4").Range("U3:X3").Copy
Sheets("ALL SURVEY").Range("E4").*PasteSpecial xlPasteValues*
Sheets("5").Range("U3:X3").Copy
Sheets("ALL SURVEY").Range("E5").*PasteSpecial xlPasteValues*
It will be much appreciated if you help me get through this hard task
Thank you

You can use a For...Next loop for this:
Sub Tester()
Dim n As Long, c As Range
Set c = ThisWorkbook.Sheets("ALL SURVEY").Range("E2") 'first destination cell
'loop through sheets
For n = 2 To 23
'convert n to string to get the correct sheet
' Sheets("2") vs Sheets(2) - by sheet Name vs. Index
With ThisWorkbook.Sheets(CStr(n)).Range("U3:X3")
c.Resize(.Rows.Count, .Columns.Count).Value = .Value 'set values
Set c = c.Offset(1, 0) 'next destination
End With
Next n
End Sub

You can do something like this:
Sub copyPaste()
Dim survey_sheet As Worksheet, count As Long
count = 1 'start pasting from this row
For Each survey_sheet In ThisWorkbook.Sheets
If survey_sheet.Name <> "ALL SURVEY" Then
survey_sheet.Range("U3:X3").Copy
Sheets("ALL SURVEY").Range("E" & count).PasteSpecial xlPasteValues
count = count + 1
End If
Next survey_sheet
End Sub
As you can see in the macro above, there is a loop For all the sheets in the Workbook. It will end when it has gone through every single one.
The If statement is to avoid copy/pasting in the final sheet ant the count variable is for pasting in the next empty row on "ALL SURVEY" sheet.

Copy Ranges by Rows
Adjust the values in the constants section. Pay attention to the Exceptions List. I added those two 'funny' names just to show that you have to separate them by the Delimiter with no spaces. The list can contain non-existing worksheet names, but it won't help, so remove them and add others if necessary.
You can resize the 'copy' range as you desire (e.g. U3:X5, Z7:AS13). The result will be each next range below the other (by rows).
Basically, the code will loop through all worksheets whose names are not in the Exceptions List and will write the values of the given range to 2D one-based arrays in an Array List. Then it will loop through the arrays of the Array List and copy the values to the resulting Data Array whose values will then be copied to the Destination Range.
The Code
Option Explicit
Sub copyByRows()
Const dstName As String = "ALL SURVEY"
Const dstFirst As String = "E2"
Const srcRange As String = "U3:X3"
Const Delimiter As String = ","
Dim ExceptionsList As String
ExceptionsList = dstName & Delimiter & "Sheet500,Sheet1000"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim dst As Worksheet: Set dst = wb.Worksheets(dstName)
Dim srCount As Long: srCount = dst.Range(srcRange).Rows.Count
Dim cCount As Long: cCount = dst.Range(srcRange).Columns.Count
Dim arl As Object: Set arl = CreateObject("System.Collections.ArrayList")
Dim Exceptions() As String: Exceptions = Split(ExceptionsList, Delimiter)
Dim ws As Worksheet
For Each ws In wb.Worksheets
If IsError(Application.Match(ws.Name, Exceptions, 0)) Then
arl.Add ws.Range(srcRange).Value
End If
Next ws
Dim Data As Variant: ReDim Data(1 To arl.Count * srCount, 1 To cCount)
Dim Item As Variant
Dim i As Long
Dim j As Long
Dim k As Long
For Each Item In arl
For i = 1 To srCount
k = k + 1
For j = 1 To cCount
Data(k, j) = Item(i, j)
Next j
Next i
Next Item
dst.Range(dstFirst).Resize(k, cCount).Value = Data
End Sub

Related

VBA: Only add unique values to excel combobox, which is populated by looping through a source sheet range on workbook open

The below code basically looks at a source sheet on workbook open, takes the values from a range and loops through adding each value to a combobox.
What I want to do is include some code to ensure only unique values, i.e. no dupes, are added.
Any ideas how I can get that working?
Thanks!
Private Sub Workbook_Open()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim Home As Worksheet
Dim Datasource As Worksheet
'Define Variables and dropdown object
Dim LastRow As Long
Dim MIDCell As Range
Dim ComboMID As ComboBox
Set Home = ActiveSheet
Set Home = Worksheets("UPDATER")
Set Datasource = wb.Sheets("LaunchCodes")
'asign dropdown object to combobox
Set ComboMID = Home.OLEObjects("ComboBox1").Object
'Empty the combobox currnetly to avoid duplicating content
ComboMID.Clear
'With and For loop to put all values in games launch code column, ignoring any blanks, into combobox
With Datasource
LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
For Each MIDCell In .Range("D2:D1000" & LastRow)
If MIDCell.Value <> "" Then
ComboMID.AddItem MIDCell.Value
End If
Next
End With
End Sub
The code below avoids looping through cells in a worksheet because it's slow. Actually, that process can be sped up by reading the list into a variable (as, in fact, my code also does) but using Excel's own RemoveDuplicates method appears more efficient.
Private Sub Workbook_Open()
' 155
Dim Wb As Workbook
Dim ComboMid As ComboBox
Dim TmpClm As Long ' number of temporary column
Dim Arr As Variant ' unique values from column D
Set Wb = ThisWorkbook
With Wb.Worksheets("UPDATER")
Set ComboMid = .OLEObjects("ComboBox1").Object
With .UsedRange
TmpClm = .Column + .Columns.Count
End With
End With
With Wb.Sheets("LaunchCodes")
' create a copy of your data (without header) in an unused column
.Cells(2, "D").CurrentRegion.Copy .Cells(1, TmpClm)
.Cells(1, TmpClm).CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlNo
Arr = .Cells(1, TmpClm).CurrentRegion.Value
.Columns(TmpClm).ClearContents
End With
With ComboMid
.List = Arr
.ListIndex = 0 ' assign first list item to Value
End With
End Sub
You don't need to clear the combo box in the above code because replacing the List property with a new array automatically removes whatever it was before.
Unique to ComboBox
To learn about the combo box study this.
You can replace the code after the line Set ComboMID = Home.OLEObjects("ComboBox1").Object with the following snippet:
Dim rng As Range
With DataSource
LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
Set rng = .Range("D2:D" & lastrow)
End With
Dim Unique As Variant
Unique = getUniqueFromRange(rng)
If Not IsEmpty(Unique) Then
ComboMID.List = Unique
End If
which uses the following function:
Function getUniqueFromRange( _
rng As Range) _
As Variant
If rng Is Nothing Then
Exit Function
End If
Dim Data As Variant
If rng.Cells.CountLarge > 1 Then
Data = rng.Value
Else
ReDim Data(1 To 1, 1 To 1)
Data(1, 1) = rng.Value
End If
cCount = UBound(Data, 2)
Dim cValue As Variant
Dim i As Long
Dim j As Long
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For i = 1 To UBound(Data, 1)
For j = 1 To cCount
cValue = Data(i, j)
If Not IsError(cValue) And Not IsEmpty(cValue) Then
.Item(cValue) = Empty
End If
Next j
Next i
If .Count > 0 Then
getUniqueFromRange = .Keys
End If
End With
End Function

Search for a match, copy entire row, and paste to corresponding

Col B on "Sheet2" contains 370 rows of data.
Starting with "Sheet2" Cell B1, I want to search for a matching value in Col B on "Sheet1" (it could be located anywhere in the first 300 rows of "Sheet1" Col B).
If a match is found, copy the entire row from "Sheet1" and paste to Row1 on "Sheet2". Then, move to "Sheet2" Cell B2 and repeat the search, this time pasting the entire row from "Sheet1" to Row2 on "Sheet2". Continue moving thru the entire column of data on "Sheet2", searching for each cell's value on "Sheet1". If a search doesn't return a match, then do not paste anything to that row on "Sheet2" and just proceed to search for the next cell on "Sheet2". (For example, if Sheet1 Col B doesn't contain a match for Sheet2 Cell B3, then nothing gets pasted in Sheet2 Row3.)
I have found the following example, which starts to help me, but it specifies the search value and doesn't loop thru the entire column of values like I am attempting to do.
Sub CopyYes()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("Sheet1")
Set Target = ActiveWorkbook.Worksheets("Sheet2")
J = 1 ' Start copying to row 1 in target sheet
For Each c In Source.Range("E1:E1000") ' Do 1000 rows
If c = "yes" Then
Source.Rows(c.Row).Copy Target.Rows(j)
j = j + 1
End If
Next c
End Sub
This should do the trick, and do it fast:
Option Explicit
Sub CopyYes()
'You need Microsoft Scripting Runtime library under Tools-References for this
Dim arrPaste As Variant: arrPaste = Sheet2.UsedRange.Value
Dim arrCopy As Variant: arrCopy = Sheet1.UsedRange.Value
Dim MyMatches As New Dictionary: Set MyMatches = CreateDictionary(arrCopy)
Dim i As Long
For i = 1 To UBound(arrPaste)
If arrPaste(i, 2) = vbNullString Then Exit For
If MyMatches.Exists(arrPaste(i, 2)) Then PasteData arrPaste, arrCopy, i, MyMatches(arrPaste(i, 2))
Next i
Sheet2.UsedRange.Value = arrPaste
Erase arrCopy
Erase arrPaste
End Sub
Private Function CreateDictionary(arr As Variant) As Dictionary
Dim i As Long
Set CreateDictionary = New Dictionary
For i = 1 To 300
CreateDictionary.Add arr(i, 2), i
Next i
End Function
Private Sub PasteData(arrPaste As Variant, arrCopy As Variant, i As Long, MyMatch As Long)
Dim j As Long
For j = 1 To UBound(arrCopy, 2)
If arrCopy(MyMatch, j) = vbNullString Then Exit For
arrPaste(i, j) = arrCopy(MyMatch, j)
Next j
End Sub
Use Range.Find to search for your matching cell
Use a Union to create a collection of the rows that are found
Once your loop is finished, copy your range all at once if the Union is not empty
Sub Shelter_In_Place()
Dim Source As Worksheet: Set Source = ThisWorkbook.Sheets("Sheet1")
Dim Target As Worksheet: Set Target = ThisWorkbook.Sheets("Sheet2")
Dim Found As Range, lr As Long
Dim CopyMe As Range
lr = Target.Range("B" & Target.Rows.Count).End(xlUp).Row
For i = 1 To lr
Set Found = Source.Range("B:B").Find(Target.Range("B" & i), LookIn:=xlWhole)
If Not Found Is Nothing Then
If Not CopyMe Is Nothing Then
Set CopyMe = Union(CopyMe, Target.Range("B" & i))
Else
Set CopyMe = Target.Range("B" & i)
End If
End If
Set Fouund = Nothing
Next i
If Not CopyMe Is Nothing Then
CopyMe.EntireRow.Copy
Source.Range("A1").PasteSpecial xlPasteValues
End If
End Sub

How do I set an array's values to be the first row of a worksheet?

I am trying to create an array where values come from the first row of a worksheet, then print those values in another sheet.
I tried to read the first row of Sheet2, store each value in the array until I hit an empty cell, then print that array in the first row of Sheet3.
I'm getting a application defined error in the while loop where I am making sure the row is not equal to Null.
Private Sub createFormatSheet()
With Worksheets("Sheet2")
Dim myTags() As Variant
Dim tag As Variant
Dim rw As Range
Dim i As Integer
i = 1
For Each rw In .Rows
While rw(i, 1) <> Null
myTags = Array(rw(i, 1))
i = i + 1
Wend
Next rw
End With
With Worksheets("Sheet3")
i = 1
For Each tag In myTag
.Cells(i, 1).Value = tag
Next tag
End With
End Sub
Here are two approaches:
Using an array (you don't need to loop through the items
Directly using ranges, no array involved
Step through the code using F8 and see what's going on
Private Sub createFormatSheet()
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Dim startRow As Long
Dim endRow As Long
Dim values As Variant
Set sourceSheet = ThisWorkbook.Worksheets("Sheet2")
Set targetSheet = ThisWorkbook.Worksheets("Sheet3")
' Array approach (no need to loop) source = column 1
startRow = 1
endRow = sourceSheet.Cells(startRow, 1).End(xlDown).Row
values = sourceSheet.Range(sourceSheet.Cells(startRow, 1), sourceSheet.Cells(endRow, 1)).Value
' Target = column 1
targetSheet.Cells(startRow, 1).Resize(endRow, 1).Value = values
' Direct range target column 2
targetSheet.Cells(startRow, 2).Resize(endRow, 1).Value = sourceSheet.Range(sourceSheet.Cells(startRow, 1), sourceSheet.Cells(endRow, 1)).Value
End Sub
Let me know if it works

Unable to populate unique values in third sheet comparing the values of the second sheet to the first one

I've got three sheets - main,specimen and output in an excel workbook. The sheet main and speciment contain some information. Some of the information in two sheets are identical but few of them are not. My intention is to paste those information in output which are available in speciment but not in main.
I've tried like [currently it fills in lots of cells producing duplicates]:
Sub getData()
Dim cel As Range, celOne As Range, celTwo As Range
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("main")
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Worksheets("specimen")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Worksheets("output")
For Each cel In ws.Range("A2:A" & ws.Cells(Rows.Count, 1).End(xlUp).row)
For Each celOne In ws1.Range("A2:A" & ws1.Cells(Rows.Count, 1).End(xlUp).row)
If cel(1, 1) <> celOne(1, 1) Then ws2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).value = celOne(1, 1)
Next celOne
Next cel
End Sub
main contains:
UNIQUE ID FIRST NAME LAST NAME
A0000477 RICHARD NOEL AARONS
A0001032 DON WILLIAM ABBOTT
A0290191 REINHARDT WESTER CARLSON
A0290284 RICHARD WARREN CARLSON
A0002029 RAYMOND MAX ABEL
A0002864 DARRYL SCOTT ABLING
A0003916 GEORGES YOUSSEF ACCAOUI
specimen contains:
UNIQUE ID FIRST NAME LAST NAME
A0288761 ROBERT HOWARD CARLISLE
A0290284 RICHARD WARREN CARLSON
A0290688 THOMAS A CARLSTROM
A0002029 RAYMOND MAX ABEL
A0002864 DARRYL SCOTT ABLING
output should contain [EXPECTED]:
UNIQUE ID FIRST NAME LAST NAME
A0288761 ROBERT HOWARD CARLISLE
A0290688 THOMAS A CARLSTROM
How can I achieve that?
If you have the latest version of Excel, with the FILTER function and dynamic arrays, you can do this with an Excel formula.
I changed your Main and Specimen data into tables.
On the Output worksheet you can then enter this formula into a single cell:
=FILTER(specTbl,ISNA(MATCH(specTbl[UNIQUE ID],mnTbl[UNIQUE ID],0)))
The remaining fields will autopopulate with the results.
For a VBA solution, I like to use Dictionaries, and VBA arrays for speed.
'set reference to microsoft scripting runtime
' or use late-binding
Option Explicit
Sub findMissing()
Dim wsMain As Worksheet, wsSpec As Worksheet, wsOut As Worksheet
Dim dN As Dictionary, dM As Dictionary
Dim vMain As Variant, vSpec As Variant, vOut As Variant
Dim I As Long, v As Variant
With ThisWorkbook
Set wsMain = .Worksheets("Main")
Set wsSpec = .Worksheets("Specimen")
Set wsOut = .Worksheets("Output")
End With
'Read data into vba arrays for processing speed
With wsMain
vMain = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=3)
End With
With wsSpec
vSpec = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=3)
End With
'add ID to names dictionary
Set dN = New Dictionary
For I = 2 To UBound(vMain, 1)
dN.Add Key:=vMain(I, 1), Item:=I
Next I
'add missing ID's to missing dictionary
Set dM = New Dictionary
For I = 2 To UBound(vSpec, 1)
If Not dN.Exists(vSpec(I, 1)) Then
dM.Add Key:=vSpec(I, 1), Item:=WorksheetFunction.Index(vSpec, I, 0)
End If
Next I
'write results to output array
ReDim vOut(0 To dM.Count, 1 To 3)
vOut(0, 1) = "UNIQUE ID"
vOut(0, 2) = "FIRST NAME"
vOut(0, 3) = "LAST NAME"
I = 0
For Each v In dM.Keys
I = I + 1
vOut(I, 1) = dM(v)(1)
vOut(I, 2) = dM(v)(2)
vOut(I, 3) = dM(v)(3)
Next v
Dim R As Range
With wsOut
Set R = .Cells(1, 1)
Set R = R.Resize(UBound(vOut, 1) + 1, UBound(vOut, 2))
With R
.EntireColumn.Clear
.Value = vOut
.Style = "Output"
.EntireColumn.AutoFit
End With
End With
End Sub
Both show the same result (except the formula solution does not bring over the column headers; but you can do that with a formula =mnTbl[#Headers] in the cell above the original formula above).
Another option is to join the values of each row in each range and store them in arrays.
Then compare arrays and output the unique values.
In this case, your uniques come from evaluating the whole row, and not just the Unique ID.
Please read code's comments and adjust it to fit your needs.
Public Sub OutputUniqueValues()
Dim mainSheet As Worksheet
Dim specimenSheet As Worksheet
Dim outputSheet As Worksheet
Dim mainRange As Range
Dim specimenRange As Range
Dim mainArray As Variant
Dim specimenArray As Variant
Dim mainFirstRow As Long
Dim specimenFirstRow As Long
Dim outputCounter As Long
Set mainSheet = ThisWorkbook.Worksheets("main")
Set specimenSheet = ThisWorkbook.Worksheets("specimen")
Set outputSheet = ThisWorkbook.Worksheets("output")
' Row at which the output range will be printed (not including headers)
outputCounter = 2
' Process main data ------------------------------------
' Row at which the range to be evaluated begins
mainFirstRow = 2
' Turn range rows into array items
mainArray = ProcessRangeData(mainSheet, mainFirstRow)
' Process specimen data ------------------------------------
' Row at which the range to be evaluated begins
specimenFirstRow = 2
' Turn range rows into array items
specimenArray = ProcessRangeData(specimenSheet, specimenFirstRow)
' Look for unique values and output results in sheet
OutputUniquesFromArrays outputSheet, outputCounter, mainArray, specimenArray
End Sub
Private Function ProcessRangeData(ByVal dataSheet As Worksheet, ByVal firstRow As Long) As Variant
Dim dataRange As Range
Dim evalRowRange As Range
Dim lastRow As Long
Dim counter As Long
Dim dataArray As Variant
' Get last row in sheet (column 1 = column A)
lastRow = dataSheet.Cells(dataSheet.Rows.Count, 1).End(xlUp).Row
' Set the range of specimen sheet
Set dataRange = dataSheet.Range("A" & firstRow & ":C" & lastRow)
' Redimension the array to the number of rows in range
ReDim dataArray(dataRange.Rows.Count)
counter = 0
' Join each row values so it's easier to compare them later and add them to an array
For Each evalRowRange In dataRange.Rows
' Use Trim function if you want to omit the first and last characters if they are spaces
dataArray(counter) = Trim(evalRowRange.Cells(1).Value) & "|" & Trim(evalRowRange.Cells(2).Value) & "|" & Trim(evalRowRange.Cells(3).Value)
counter = counter + 1
Next evalRowRange
ProcessRangeData = dataArray
End Function
Private Sub OutputUniquesFromArrays(ByVal outputSheet As Worksheet, ByVal outputCounter As Long, ByVal mainArray As Variant, ByVal specimenArray As Variant)
Dim specimenFound As Boolean
Dim specimenCounter As Long
Dim mainCounter As Long
' Look for unique values ------------------------------------
For specimenCounter = 0 To UBound(specimenArray)
specimenFound = False
' Check if value in specimen array exists in main array
For mainCounter = 0 To UBound(mainArray)
If specimenArray(specimenCounter) = mainArray(mainCounter) Then specimenFound = True
Next mainCounter
If specimenFound = False Then
' Write values to output sheet
outputSheet.Range("A" & outputCounter).Value = Split(specimenArray(specimenCounter), "|")(0)
outputSheet.Range("B" & outputCounter).Value = Split(specimenArray(specimenCounter), "|")(1)
outputSheet.Range("C" & outputCounter).Value = Split(specimenArray(specimenCounter), "|")(2)
outputCounter = outputCounter + 1
End If
Next specimenCounter
End Sub

vba, copy data from sparse column to form a new dense column

An over-simplified description of my problem is illustrated in the figures below. I want to transform sparse data from a column in the Page1 worksheet to dense and then load it in a dense range in the Page2 worksheet.
My solution so far is that in the following code snippet. I would like to know if there is a more efficient alternative to achieve this goal, namely without a for loop or at least without the j variable.
Sub CopyFromMultipleRanges()
With Worksheets("Page1")
.Range("A1:A5").Value = 1
.Range("A8:A10").Value = 2
Dim c_cell As Range
Dim j As Long
j = 1
For Each c_cell In .Range("A1:A5,A8:A10")
Worksheets("Page2").Range("A" & j).Value = c_cell.Value
j = j + 1
Next
End With
Worksheets("Page2").Activate
End Sub
Initial column where data is sparse.
Final dense data column.
You can do this if you want to remove the blanks on the same sheet. If not just copy the data to a new sheet and then run this on that range
Sub Delete_Blank_Rows()
On Error Resume Next
Range("A1:A10").Select
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
Here's how I would do it:
'create a collection to store the data
Dim bin As New Collection
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim size As Long
Dim i As Long
Dim v As Variant
'set worksheet references
Set ws1 = Excel.Application.ThisWorkbook.Worksheets("Page1")
Set ws2 = Excel.Application.ThisWorkbook.Worksheets("Page2")
With ws1
size = .UsedRange.Rows.Count
'loop through the range to pick up the data from non-empty cells
For i = 1 To size
'if the cell is not empty, then add the value to the collection
If Not IsEmpty(.Cells(i, 1).Value) Then
bin.Add .Cells(i, 1).Value
End If
Next
'loop through the bin contents
i = 1
For Each v In bin
ws2.Cells(i, 1).Value = v
i = i + 1
Next
End With
Hope it helps!
Update:
I tested this code and it works:
Sub test()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Excel.Application.ThisWorkbook.Worksheets(1)
Set ws2 = Excel.Application.ThisWorkbook.Worksheets(2)
ws1.Range("A:A").SpecialCells(xlCellTypeConstants).Copy ws2.Range("A:A")
End Sub
you can read more about Range.SpecialCells here. learn something new everyday!
This assumes that you are considering the all rows with the lower and upper row limits of the ranges given ie. that "A1:A5" and "A8:A10" is indeed "A1:A10".
Option Explicit
Public Sub CopyFromMultipleRanges()
Dim rng As Range: Set rng = ThisWorkbook.Worksheets("Page1").Range("A1:A10")
Application.ScreenUpdating = False
If Application.WorksheetFunction.CountBlank(rng) = rng.Count Then Exit Sub
With rng
.AutoFilter
.AutoFilter 1, "<>"
.SpecialCells(xlCellTypeVisible).Copy Worksheets("Page2").Range("A1")
.AutoFilter
Application.ScreenUpdating = True
End With
End Sub

Resources