So I have some data that I will need to run my macro on monthly. My code works for what I need it for but I thought this might be a good chance for me to try and learn how to loop something that's so repetitive as I'm still pretty new to all this. So below is my code and basically all it does is copy all contents in column A and another specified column, pastes them in a new sheet, renames the sheet after a certain cell on Sheet1 and deletes any blank rows that contains a blank cell. I just simply copied and pasted the original recorded macro and made some changes to make it do the whole sheet.
I would to try and learn how to slim it down and loop rather than having to copy and paste it. This is more of a learning thing for me as this macro already works for what I need.
Thanks a lot!
Sub test()
'
' test Macro
'
'
Application.ScreenUpdating = False
Range("A:A,B:B").Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
On Error Resume Next
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
ActiveSheet.UsedRange
ActiveSheet.Name = Sheet1.Range("B1").Value
Sheets("Sheet1").Activate
Range("A:A,C:C").Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
On Error Resume Next
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
ActiveSheet.UsedRange
ActiveSheet.Name = Sheet1.Range("C1").Value
Sheets("Sheet1").Activate
Range("A:A,D:D").Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
On Error Resume Next
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
ActiveSheet.UsedRange
ActiveSheet.Name = Sheet1.Range("D1").Value
Sheets("Sheet1").Activate
Range("A:A,E:E").Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
On Error Resume Next
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
ActiveSheet.UsedRange
ActiveSheet.Name = Sheet1.Range("E1").Value
Sheets("Sheet1").Activate
Range("A:A,F:F").Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
On Error Resume Next
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
ActiveSheet.UsedRange
ActiveSheet.Name = Sheet1.Range("F1").Value
Sheets("Sheet1").Activate
Range("A:A,G:G").Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
On Error Resume Next
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
ActiveSheet.UsedRange
ActiveSheet.Name = Sheet1.Range("G1").Value
Sheets("Sheet1").Activate
Range("A:A,H:H").Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
On Error Resume Next
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
ActiveSheet.UsedRange
ActiveSheet.Name = Sheet1.Range("H1").Value
Sheets("Sheet1").Activate
Range("A:A,I:I").Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
On Error Resume Next
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
ActiveSheet.UsedRange
ActiveSheet.Name = Sheet1.Range("I1").Value
Sheets("Sheet1").Activate
Range("A:A,J:J").Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
On Error Resume Next
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
ActiveSheet.UsedRange
ActiveSheet.Name = Sheet1.Range("J1").Value
Sheets("Sheet1").Activate
Range("A:A,K:K").Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
On Error Resume Next
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
ActiveSheet.UsedRange
ActiveSheet.Name = Sheet1.Range("K1").Value
Sheets("Sheet1").Activate
Range("A:A,L:L").Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
On Error Resume Next
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
ActiveSheet.UsedRange
ActiveSheet.Name = Sheet1.Range("L1").Value
Sheets("Sheet1").Activate
Range("A:A,M:M").Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
On Error Resume Next
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
ActiveSheet.UsedRange
ActiveSheet.Name = Sheet1.Range("M1").Value
Sheets("Sheet1").Activate
Range("A:A,N:N").Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
On Error Resume Next
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
ActiveSheet.UsedRange
ActiveSheet.Name = Sheet1.Range("N1").Value
Sheets("Sheet1").Activate
End Sub
I would do something like:
Sub test()
Dim CurrentColumn As String 'define a variable
For i = 1 To 13 'loop over the letter B to N (13 values if I counted right)
CurrentColumn = Chr(65 + i) 'Here you play with ascii table 65 is the code for A, 66 for B, etc.
Range("A:A," & CurrentColumn & ":" & CurrentColumn).Select 'replace in the string the fix value by our variable
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
On Error Resume Next
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
ActiveSheet.UsedRange
ActiveSheet.Name = Sheets("Sheet1").Range(CurrentColumn & "1").Value 'same here
Sheets("Sheet1").Activate
Next
End Sub
Exemple of the ascii table
Tell me if you need more details than what is in the comments
I would make it a sub-procedure...
Try this out:
Sub test()
Dim SecondColumnIndexNumber As Integer
Application.ScreenUpdating = False
For SecondColumnIndexNumber = 2 To 13
DoTheMove (SecondColumnIndexNumber)
Next
Application.ScreenUpdating = True
End Sub
Sub DoTheMove(SecondColumnIndexNumber As Integer)
' This takes a number as the input for the second column that will be copied over
' For example 2 corresponds to copying over columns A (always the case) and column B - Range("A:A,B:B")
' For example 4 corresponds to copying over columns A (always the case) and column D - Range("A:A,D:D")
Dim NewSheet As Worksheet
Dim SecondColumn As Range
Dim RangeToCopy As Range
Set NewSheet = Sheets.Add(After:=Sheets(Sheets.Count))
Set SecondColumn = Sheets("Sheet1").Columns(SecondColumnIndexNumber)
Set RangeToCopy = Union(Sheets("Sheet1").Range("A:A"), SecondColumn)
NewSheet.Activate
RangeToCopy.Copy NewSheet.Range("A1")
On Error Resume Next
NewSheet.Range("A:B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
NewSheet.Name = Sheet1.Cells(1, SecondColumn).Value
End Sub
Related
This is a screenshot of my excel doc.
I want to apply filters based on values: Bimbo Mexico, Bimbo Canada and copy and paste the values(from column A & B) in a new sheet. I want to do this using macro as I am building a template for a client. Is there a way to do this? I know it can be done manually using filters manually but I want it to be based on a macro
I want the output like this:
I used recording macro and this is the macro I got,
Sub RecordedMacro()
'
' RecordedMacro Macro
'
' Keyboard Shortcut: Ctrl+l
'
Sheets("report").Select
Range("C1").Select
ActiveSheet.Range("$A$1:$S$1001").AutoFilter Field:=3, Criteria1:="Barcel"
Columns("L:L").Select
Selection.Copy
Sheets("SkuRounds").Select
Columns("S:S").Select
ActiveSheet.Paste
Sheets("report").Select
ActiveSheet.Range("$A$1:$S$1001").AutoFilter Field:=3, Criteria1:= _
"Bimbo Canada"
Columns("L:L").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("SkuRounds").Select
Columns("T:T").Select
ActiveSheet.Paste
Sheets("report").Select
ActiveSheet.Range("$A$1:$S$1001").AutoFilter Field:=3, Criteria1:= _
"Bimbo Latin Centro"
Columns("L:L").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("SkuRounds").Select
Columns("U:U").Select
ActiveSheet.Paste
Sheets("report").Select
ActiveSheet.Range("$A$1:$S$1001").AutoFilter Field:=3, Criteria1:= _
"Bimbo México"
Columns("L:L").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("SkuRounds").Select
Columns("V:V").Select
ActiveSheet.Paste
End Sub
I am copying data from sheet(report) to sheet(skurounds)
Give this a try:
Sub tgr()
Dim wb As Workbook
Dim wsReport As Worksheet
Dim wsSKU As Worksheet
Dim dictUnqCompanies As Object
Dim aCompanies As Variant
Dim vCompany As Variant
Dim lDestCol As Long
Set wb = ActiveWorkbook
Set wsReport = wb.Sheets("report")
Set wsSKU = wb.Sheets("skurounds")
Set dictUnqCompanies = CreateObject("Scripting.Dictionary")
lDestCol = wsSKU.Columns("S").Column
'Clear previous results
wsSKU.Range(wsSKU.Cells(1, "S"), wsSKU.Cells(1, wsSKU.Columns.Count)).EntireColumn.Clear
With wsReport.Range("C2", wsReport.Cells(wsReport.Rows.Count, "C").End(xlUp))
If .Row < 2 Then Exit Sub 'No data
If .Rows.Count = 1 Then
'Only 1 row of data
wsSKU.Cells(1, lDestCol).Value = .Value
.Parent.Cells(.Row, "L").Copy wsSKU.Cells(2, lDestCol)
Exit Sub
Else
aCompanies = .Value
End If
End With
For Each vCompany In aCompanies
If Not dictUnqCompanies.exists(vCompany) Then
dictUnqCompanies.Add vCompany, vCompany
With wsReport.Range("C1", wsReport.Cells(wsReport.Rows.Count, "C").End(xlUp))
.AutoFilter 1, vCompany
wsSKU.Cells(1, lDestCol).Value = vCompany
Intersect(.Parent.Columns("L"), .Offset(1).EntireRow).Copy wsSKU.Cells(2, lDestCol)
lDestCol = lDestCol + 1
.AutoFilter
End With
End If
Next vCompany
End Sub
I am attempting to create a macro that will pull data from several sheets and display them in an 'OVERVIEW' sheet.
At the moment I have the following:
Sheets("Sheet1).Select
ActiveCell.Range("A1:G7").Select
SELECTION.Copy
Sheets("OVERVIEW").Select
ActiveCell.Select
ActiveSheet.Paste
Sheets("Sheet2").Select
ActiveCell.Range("A1:G7").Select
Application.CutCopyMode = False
SELECTION.Copy
Sheets("OVERVIEW").Select
ActiveCell.Offset(7, 0).Range("A1").Select
ActiveSheet.Paste
Sheets("Sheet3").Select
ActiveCell.Range("A1:G2").Select
Application.CutCopyMode = False
SELECTION.Copy
Sheets("OVERVIEW").Select
ActiveCell.Offset(7, 0).Range("A1").Select
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=-12
ActiveCell.Columns("A:A").EntireColumn.EntireColumn.AutoFit
ActiveCell.Offset(0, 1).Columns("A:A").EntireColumn.Select
Application.CutCopyMode = False
Unfortunately, this currently only copies the data from the first sheet. I would much rather have something along the lines of the following pseudo code
sub COPY1()
Selection = []
curentRow = 1
while(notEmpty(cell(AcurentRow)))
Selection.add(curentRow)
curentRow++
return Selection
End Sub
sub PASTE1(selection)
curentRow=1
while(notEmpty(cell(AcurentRow)))
curentRow++
paste(selection)
End Sub
You can loop through the sheets, and it will skip over "OVERVIEW"
Sub Button1_Click()
Dim ws As Worksheet, sh As Worksheet, LstRw As Long
Set ws = Sheets("OVERVIEW")
For Each sh In Sheets
If sh.Name <> ws.Name Then
With sh
LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("A1:G" & LstRw).Copy
ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteValues
End With
End If
Next sh
Application.CutCopyMode = False
End Sub
sub copy_to_overview()
currentRow = 1
while (notempty(cell(currentrow))
currentrow.copy
sheet("overwiev").currentrow.paste
currentrow = currentrow + 1
wend
end sub
I recorded a macro & integrated together with some codes I researched and tested, which worked individually. However, having combined them all together, I stumbled across errors running the macro. Pop out a message box which displays
Compile Error: Expected End With
Would appreciate all the help I could get to solve it
Sub Book1UpdateDelete()
'
' Book1UpdateDelete Macro
'
' Keyboard Shortcut: Ctrl+g
'
'Select values in a column from specified workbook and sheet
Dim LR As Long, cell As Range, rng As Range
Windows("Y738 Data").Activate
With Sheets("Graph data")
LR = .Range("B" & Rows.Count).End(xlUp).Row
For Each cell In .Range("B4:B" & LR)
If cell.Value <> "" Then
If rng Is Nothing Then
Set rng = cell
Else
Set rng = Union(rng, cell)
End If
End If
Next cell
rng.Select
End With
Selection.Copy
'Open next workbook
Windows("Y783").Activate
'Open Sheet L
Sheets("L").Select
'Select empty field fromn column AA
Range("AA" & Rows.Count).End(xlUp).Offset(1).Select
'paste selection to empty field
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Go back to previous workbook & delete column
Windows("Y738").Activate
With Sheets("Graph data")
Columns("B:B").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Sheets("Graph Data").Select
End Sub
You've missed and end with at the bottom of your code.
Try this (untested)
Sub Book1UpdateDelete()
'
' Book1UpdateDelete Macro
'
' Keyboard Shortcut: Ctrl+g
'
'Select values in a column from specified workbook and sheet
Dim LR As Long, cell As Range, rng As Range
Windows("Y738 Data").Activate
With Sheets("Graph data")
LR = .Range("B" & Rows.Count).End(xlUp).Row
For Each cell In .Range("B4:B" & LR)
If cell.Value <> "" Then
If rng Is Nothing Then
Set rng = cell
Else
Set rng = Union(rng, cell)
End If
End If
Next cell
rng.Select
End With
Selection.Copy
'Open next workbook
Windows("Y783").Activate
'Open Sheet L
Sheets("L").Select
'Select empty field fromn column AA
Range("AA" & Rows.Count).End(xlUp).Offset(1).Select
'paste selection to empty field
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Go back to previous workbook & delete column
Windows("Y738").Activate
With Sheets("Graph data")
Columns("B:B").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Sheets("Graph Data").Select
End with
End Sub
I have code below help me to copy filtered value and paste to different worksheet.
It always stop at apple... (Apple result looks fine)and pop up Run-time error'1004' Application-defined or object-defined error..
Sub CoWFTR()
'Filter out Apple
Sheet1.Range("A1:ER1").Select
Selection.AutoFilter Field:=11, Criteria1:=Array( _
"ILOVEApple"), Operator:=xlFilterValues
'Copy and Paste to Apple Tab
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets("Apple").Select
ActiveSheet.Paste
Sheet1.Range("A1").Select
Application.CutCopyMode = False
'Clear Filter
On Error Resume Next
Sheet1.ShowAllData
On Error GoTo 0
'Filter out Banana
Sheet1.Range("A1:ER1").Select
Selection.AutoFilter Field:=11, Criteria1:=Array( _
"ILOVEBanana"), Operator:=xlFilterValues
'Copy and Paste to Banana Tab
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets("Banana").Select
ActiveSheet.Paste
Sheet1.Range("A1").Select
Application.CutCopyMode = False
'Clear Filter
On Error Resume Next
Sheet1.ShowAllData
On Error GoTo 0
End Sub
Copy the 2 procedures bellow in the same module, and update FILTER_ITEMS with your criteria:
Option Explicit
Public Sub CoWFTR()
Const FILTER_COL As Long = 11 'K
Const FILTER_ITEMS As String = "ILOVEApple,ILOVEBanana"
Dim wsFrom As Worksheet, wsDest As Worksheet, fi As Variant, i As Long
Set wsFrom = Sheet1 '<--- Update this
fi = Split(FILTER_ITEMS, ",")
Application.ScreenUpdating = False
For i = 0 To UBound(fi)
Set wsDest = CheckNamedSheet(fi(i))
With wsFrom.UsedRange
.AutoFilter Field:=11, Criteria1:="=" & fi(i), Operator:=xlFilterValues
.Copy 'Copy visible data
End With
With wsDest.Cells
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteAll
Application.CutCopyMode = False
wsDest.Activate
.Cells(1, 1).Select
End With
Next
With wsFrom
.Activate
.Cells(1, 1).Copy
.UsedRange.AutoFilter
End With
Application.ScreenUpdating = True
End Sub
This manages the new sheets
Private Function CheckNamedSheet(ByVal sheetName As String) As Worksheet
Dim ws As Worksheet, result As Boolean, activeWS As Worksheet
Set activeWS = IIf(ActiveSheet.Name = sheetName, Worksheets(1), ActiveSheet)
For Each ws In Worksheets
If ws.Name = sheetName Then
Application.DisplayAlerts = False
ws.Delete 'delete sheet if it already exists
Application.DisplayAlerts = True
Exit For
End If
Next
Set ws = Worksheets.Add(After:=Worksheets(Worksheets.Count)) 'create a new one
ws.Name = sheetName
activeWS.Activate
Set CheckNamedSheet = ws
End Function
For your code, the error you are getting is at this line:
Sheet1.Range("A1").Select
It repeats for Bananas as well, and is triggered by the fact that it tries to select Range("A1") on Sheet1, but the active sheet is Apple (or Banana), so to fix the issues you need to add this line:
Sheet1.Activate
Here is your code, fixed:
Sub CoWFTR()
'Filter out Apple
Sheet1.Range("A1:ER1").Select
Selection.AutoFilter Field:=11, Criteria1:=Array( _
"ILOVEApple"), Operator:=xlFilterValues
'Copy and Paste to Apple Tab
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets("Apple").Select
ActiveSheet.Paste
Sheet1.Activate 'Fix to error 1004
Sheet1.Range("A1").Select
Application.CutCopyMode = False
'Clear Filter
On Error Resume Next
Sheet1.ShowAllData
On Error GoTo 0
'Filter out Banana
Sheet1.Range("A1:ER1").Select
Selection.AutoFilter Field:=11, Criteria1:=Array( _
"ILOVEBanana"), Operator:=xlFilterValues
'Copy and Paste to Banana Tab
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets("Banana").Select
ActiveSheet.Paste
Sheet1.Activate 'Fix to error 1004
Sheet1.Range("A1").Select
Application.CutCopyMode = False
'Clear Filter
On Error Resume Next
Sheet1.ShowAllData
On Error GoTo 0
End Sub
I think it is useful using xlCellTypeVisible. And Use Array.
Sub CoWFTR()
Dim WS As Worksheet, toWs As Worksheet
Dim rngDB As Range, rngTo As Range
Dim vCriteria, vName, i As Integer
Set WS = Sheet1
Set toWs = Sheets("Apple")
Set rngDB = WS.Range("a1").CurrentRegion
vCriteria = Array("ILOVEApple", "ILOVEBanana")
vName = Array("Apple", "Banana")
For i = 0 To UBound(vCriteria)
If WS.FilterMode Then
WS.ShowAllData
End If
Set toWs = Sheets(vName(i))
Set rngTo = toWs.Range("a" & Rows.Count).End(xlUp)(2)
rngDB.AutoFilter Field:=11, Criteria1:=Array( _
vCriteria(i)), Operator:=xlFilterValues
rngDB.SpecialCells(xlCellTypeVisible).Offset(1).Copy rngTo
Next i
If WS.FilterMode Then
WS.ShowAllData
End If
End Sub
Here is my code, it s simple! but i have an error
at this line "wb.Sheets("Sheet1").Range(Cells(3, j), Cells(10, j)).Select"
Private Sub CommandButton1_Click()
Dim fd As Office.FileDialog
Dim wb As Workbook
Dim ms As Workbook
Dim Path As String
Dim i As Integer
Dim j As Integer
Set ms = ThisWorkbook
Path = "D:\SYSTEM DATA\\EVT.xlsx"
Set wb = Workbooks.Open(Path)
wb.Activate
For i = 2 To 12 Step 1
If wb.Sheets(1).Cells(1, i).Value = "EVT006" Then
j = i
Exit For
End If
Next i
wb.Sheets("Sheet1").Range(Cells(3, j), Cells(10, j)).Select 'the error line
Selection.Copy
ms.Activate
With ms
Sheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Application.CutCopyMode = False
End With
wb.Close True
End Sub
i dont know why ?
Please help
Be sure to declare your wb on your cells within the range as well.
Private Sub CommandButton1_Click()
Dim fd As Office.FileDialog
Dim wb As Workbook
Dim ms As Workbook
Dim Path As String
Dim i As Integer
Dim j As Integer
Set ms = ThisWorkbook
Path = "D:\SYSTEM DATA\\EVT.xlsx"
Set wb = Workbooks.Open(Path)
wb.Activate
For i = 2 To 12 Step 1
If wb.Sheets(1).Cells(1, i).Value = "EVT006" Then
j = i
Exit For
End If
Next i
wb.Sheets("Sheet1").Range(wb.Sheets("Sheet1").Cells(3, j), wb.Sheets("Sheet1").Cells(10, j)).Select 'the error line
Selection.Copy
ms.Activate
With ms
Sheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Application.CutCopyMode = False
End With
wb.Close True
End Sub
in
wb.Sheets("Sheet1").Range(Cells(3, j), Cells(10, j)).Select
you have wb.Sheets("Sheet1").Range( referencing worksheet "Sheet1" of workbook wb, while Cells(3, j) and Cells(10, j) are referencing active sheet of active workbook, where this latter is still wb (due to preceeding wb.Activate) while the former is the worksheet wb is opening with (i.e. the active sheet at the time it was last saved) which is not assured in any way to be "Sheet1"
furthemore you should avoid Activate/Select/ActiveXXX/Selection pattern and use fully qualified range references
finally you wouldn't need any wb.Activate statement after Set wb = Workbooks.Open(Path) one, since at any workbook opening it becomes the Active one
so substitute
wb.Sheets("Sheet1").Range(Cells(3, j), Cells(10, j)).Select 'the error line
Selection.Copy
ms.Activate
With ms
Sheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Application.CutCopyMode = False
End With
with
With Wb.Sheets("Sheet1")
.Range(.Cells(3, j), .Cells(10, j)).Copy
ms.Sheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Application.CutCopyMode = False
End With