Copying Data to another workbook - excel

I use two workbooks (obviously based on the question:)), from the first one (as you will see in the code below) gets sorted by the data in column "B". The data in this column is just a number based on the month (11=November, December=12, etc.). For this question (and it will provide the answer for my other monthly workbooks), need to copy all the rows of data (columns A:AE) in column B to another workbook (which is already open), and paste the data into the empty row at the bottom. I have the sort part working fine. I am trying to add in the copy & paste function into the code, but can't get it to work. HELP!
Here is the code I have tried (but can't figure out how to get focus to the target workbook):
Sub Extract_Sort_1512_December()
' This line renames the worksheet to "Extract"
Application.ScreenUpdating = False
ActiveSheet.Name = "Extract"
' This line autofits the columns C, D, O, and P
Range("C:C,D:D,O:O,P:P").Columns.AutoFit
' This unhides any hidden rows
Cells.EntireRow.Hidden = False
Dim LR As Long
With ActiveWorkbook.Worksheets("Extract").Sort
With .SortFields
.Clear
.Add Key:=Range("B2:B2000"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
End With
.SetRange Range("A2:Z2000")
.Apply
End With
For LR = Range("B" & Rows.Count).End(xlUp).Row To 2 Step -1
If Range("B" & LR).Value <> "12" Then
Rows(LR).EntireRow.Hidden = True
End If
Next LR
Cells.WrapText = False
Sheets("Extract").Range("A2").Select
Dim LastRow As Integer, i As Integer, erow As Integer
LastRow = ActiveSheet.Range(“A” & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
If Cells(i, 2) = “12” Then
Range(Cells(i, 1), Cells(i, 31)).Select
Selection.Copy
ActiveWorkbook(“Master File - Swivel - December 2015.xlsm”).Select
Worksheets(“Master”).Select
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 1).Select
ActiveSheet.Paste
End If
Next i
Application.ScreenUpdating = True
End Sub
I have found this code below, but do not know how to insert it properly into my code above. The thing that makes me weary is that the workbooks are already open. The target workbook is located on our SharePoint site and I do not know how (or if) you can use VBA code to open it to your desktop.
Here is the other code:
Sub Demo()
Dim wbSource As Workbook
Dim wbTarget As Workbook
' First open both workbooks :
Set wbSource = Workbooks.Open(" ") ' <<< path to source workbook
Set wbTarget = ActiveWorkbook ' Workbooks.Open(" ") ' <<< path to destination workbook
'Now, transfer values from wbSource to wbTarget:
wbTarget.Sheets("Sheet1").Range("B2").Value = wbSource.Sheets("Sheet3").Range("H4")
wbTarget.Sheets("Sheet1").Range("B3").Value = wbSource.Sheets("Sheet3").Range("J10")
'Close source:
wbSource.Close
End Sub

I have modified your code slightly, but kept most of it as is.
I think the problem was related to the way in which you were trying to activate the workbook where the data was to be pasted. Normally the Activate command is used with workbooks, as opposed to Select. However, I bypassed the whole activation of the new workbook, because it would require you to then "re-activate" the original workbook before copying the next line. Otherwise you would be copying from the active workbook, which would now be the one to be pasted into. Please see the code - it should be fairly straightforward.
Sub Extract_Sort_1512_December()
Application.ScreenUpdating = False
' This line renames the worksheet to "Extract"
ActiveSheet.Name = "Extract"
' This line autofits the columns C, D, O, and P
Range("C:C,D:D,O:O,P:P").Columns.AutoFit
' This unhides any hidden rows
Cells.EntireRow.Hidden = False
Dim LR As Long
With ActiveWorkbook.Worksheets("Extract").Sort
With .SortFields
.Clear
.Add Key:=Range("B2:B2000"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
End With
.SetRange Range("A2:Z2000")
.Apply
End With
For LR = Range("B" & Rows.Count).End(xlUp).Row To 2 Step -1
If Not Range("B" & LR).Value = "12" Then
Rows(LR).EntireRow.Hidden = True
End If
Next LR
Cells.WrapText = False
Sheets("Extract").Range("A2").Select
Dim LastRow As Integer, i As Integer, erow As Integer
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
If Cells(i, 2) = "12" Then
' As opposed to selecting the cells, I just copy them directly
Range(Cells(i, 1), Cells(i, 31)).Copy
' As opposed to "Activating" the workbook, and selecting the sheet, I just paste the cells directly
With Workbooks("Master File - Swivel - December 2015.xlsm").Sheets("Master")
erow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
.Cells(erow, 1).PasteSpecial xlPasteAll
End With
Application.CutCopyMode = False
End If
Next i
Application.ScreenUpdating = True
End Sub

Related

Code modification to copy all data in a row or the whole row instead of only copying a cell

New VBA user here, the below code matches the 1st column in a worksheet with the 1st column in another worksheet using vlookup then copies the first cell from 1st to 2nd as the screenshots.
Code
Sub solution()
Dim oldRow As Integer
Dim newRow As Integer
Dim lrow_output As Integer 'variable indicating last fulfilled row
Dim WB_Input As Workbook
Dim WB_Output As Workbook
Dim WS_Input As Worksheet
Dim WS_Output As Worksheet
Dim funcStr As String
Set WB_Input = Workbooks("input")
Set WB_Output = Workbooks("output1")
Set WS_Input = WB_Input.Worksheets("input")
Set WS_Output = WB_Output.Worksheets("Sheet1")
With WS_Output
lrow_output = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
With WS_Input
funcStr = "=IFERROR(VLOOKUP(" & Cells(1, 1).Address(False, False) & "," & "'[" & WB_Input.Name & "]" & .Name & "'!" & Range(.Columns(1), .Columns(2)).Address & ",2,0),"""")"
End With
With WS_Output
.Cells(1, 2).Formula = funcStr
.Cells(1, 2).Copy
Range(.Cells(1, 2), .Cells(lrow_output, 2)).PasteSpecial xlPasteFormulas
WS_Output.Calculate
Range(.Cells(1, 2), .Cells(lrow_output, 2)).Copy
Range(.Cells(1, 2), .Cells(lrow_output, 2)).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
End Sub
Problem: I need the code to copy and paste the all data in the row, not just the first cell.
Problem2:If possible I need the code to scan multiple sheets, not just one so it would be 1 input main workbook sheet and 4 output sheets in the output workbook.
Problem3(Optional): if possible I need the successfully matched and copied rows in the input workbook to be colored to tell them from the unsuccessful matches.
Thank you in advance, I really appreciate all the possible aid.
Here is a quick macro that will take the active cell row copy it and then select specified sheet and paste it in active cell row:
Sub CopyPaste()
'
' CopyPaste Macro
'
'
ActiveCell.Rows("1:1").EntireRow.Select
Selection.Copy
Sheets("Sheet#").Select
ActiveCell.Rows("1:1").EntireRow.Select
ActiveSheet.Paste
End Sub

VBA to set Range/ Print area in consolidating the Master Sheet

I have this VBA code which is used to consolidate the different tabs to one single sheet.Now the issue here is its taking too long to copy each line item to one single sheet. Need an update so that i could set print area as range and copy the sheets back to one.
ActiveWorkbook.Worksheets("Master Sheet").Activate
Rows("2:" & Rows.Count).Cells.ClearContents
totalsheets = Worksheets.Count
For i = 1 To totalsheets
If Worksheets(i).Name <> "Master Sheet" Then
lastrow = Worksheets(i).Cells(Rows.Count, 1).End(xlUp).Row
For j = 2 To lastrow
Worksheets(i).Activate
Worksheets(i).AutoFilterMode = False
Worksheets(i).Rows(j).Select
Selection.Copy
Worksheets("Master Sheet").Activate
lastrow = Worksheets("Master Sheet").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("Master Sheet").Cells(lastrow + 1, 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Next
End If
Next
MsgBox "Completed"
ActiveWorkbook.Save
End Sub
First of all, avoid selecting worksheets and cells: Worksheets(i).Activate, Rows(j).Select. This is the most time-consuming. Usually it can be replaced with direct links.
Next, don't repeat Worksheets(i).AutoFilterMode = False inside the loop for j, it will be enough to do it once before For j = 2 To lastrow.
Third, don't copy row-by-row. Instead, copy the entire sheet:
Dim lastCell As Range
Set lastCell = Sheets("Sheet1").Range("A1").SpecialCells(xlLastCell)
Sheets("Sheet1").Range(Range("A1"), lastCell).Copy
Try this code, please. It it is fast, working mostly in memory, using arrays:
Sub testConsolidate()
Dim sh As Worksheet, shM As Worksheet, lastRowM As Long, arrUR As Variant
Set shM = ActiveWorkbook.Worksheets("Master Sheet")
shM.Rows("2:" & Rows.Count).Cells.Clear
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> "Master Sheet" Then
sh.AutoFilterMode = False
lastRowM = shM.Cells(Cells.Rows.Count, 1).End(xlUp).row
arrUR = sh.UsedRange.Offset(1).value 'copy from row 2 down
shM.Cells(lastRowM + 1, 1).Resize(UBound(arrUR, 1), _
UBound(arrUR, 2)).value = arrUR
End If
Next
MsgBox "Completed"
ActiveWorkbook.Save
End Sub

Copying looped data from one workbook and paste to another

I have written this code, and it works when doing it from one sheet to another. (Same workbook). But when i loop through the rows from workbook to workbook i get "Run time error 9" Subscript out of range.
I've checked several times if the filenames are as stated in the code, and it doesn't seem to be the problem. Also if I in the first piece write y.sheets("Tavledisplay") instead of worksheets("Tavledisplay") the debugger tells me there's a problem there. Doing it the latter way, it sends 1 loop of data, and stops at y.sheets("Tavledisplay").Activate.
My code:
Dim x As Workbook
Dim y As Workbook
Set x = Workbooks.Open("C:\Users\u054939\Desktop\Diverse filer\Safecard\Safecardmaster.xlsm")
Set y = Workbooks.Open("C:\Users\u054939\Desktop\Diverse filer\Safecard\Tavleark1.xlsm")
a = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To a
If Worksheets("Tavledisplay").Cells(i, 14).Value = "Ja" Then
Worksheets("Tavledisplay").Rows(i).Select
Selection.Copy
x.Sheets("Løsninger").Activate
b = Worksheets("Løsninger").Cells(Rows.Count, 1).End(xlUp).Row
x.Sheets("Løsninger").Cells(b + 1, 1).Select
ActiveSheet.Paste
y.Sheets("Tavledisplay").Activate
Selection.ClearContents
End If
Next i
Application.CutCopyMode = False
x.Sheets("Løsninger").Select
I expect the code to loop through all the given rows, where there is a "Ja" in column 14, and pasting them into my other workbook sheet "Løsninger" and deleting them from the other workbook.
You don't need to loop through each loop, a simple filter will do the trick:
Option Explicit
Sub Test()
Dim x As Workbook
Dim y As Workbook
Dim CopyRange As Range
Dim LastRow As Long
Set x = Workbooks.Open("C:\Users\u054939\Desktop\Diverse filer\Safecard\Safecardmaster.xlsm")
Set y = Workbooks.Open("C:\Users\u054939\Desktop\Diverse filer\Safecard\Tavleark1.xlsm")
'Look for the range to copy and set it
With y.Worksheets("Tabledisplay")
.UsedRange.AutoFilter Field:=14, Criteria1:="Ja"
LastRow = .Cells(.Rows.Count, 14).End(xlUp).Row
Set CopyRange = .Range("A2", .Cells(LastRow, .UsedRange.Columns.Count)).SpecialCells(xlCellTypeVisible)
.AutoFilterMode = False
End With
'Paste it to the other sheet
With x.Worksheets("Løsninger")
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
CopyRange.Copy .Cells(LastRow, 1)
End With
'Delete the range from the original sheet
CopyRange.Delete
End Sub

cut copy paste looped instruction betwene two sheets

I have had some answers to my question below, but despite numerous attempts I think my code is now just a total mess, and cannot fathom where it is wrong.
So I have a range A12:N112 that needs sorted on row A with descending values.
Next I need to copy each row (B:L) where column A has a "1" in it and paste it into the first blank row in another workbook, based on column D being blank. I then need to copy the number generated in column A for the row I have just pasted into, and then paste this back into the original row I copied in row N of the first spreadsheet.
I need this then to loop until we reach the first value of "0" in the first spreadsheet.
Here is my code, and although I can get the sort to work, I cannot get anything at all to copy or paste. This is similar to code i've used before for a single cut copy paste, but cannot get it to work at all here.
Dim r As Long
Dim lr As Long
Dim wkb As Workbook
Dim ws As Worksheet
Dim wkb2 As Workbook
Dim ws2 As Worksheet
Set wkb = ThisWorkbook
Set ws = wkb.Worksheets("Data Entry")
Set wkb2 = Workbooks.Open("\\srveurfcl03.nov.com\IS-GBR-GLBISETNRegister$\Serial No Trial\Serialisation Log.xlsx")
Set ws2 = wkb2.Worksheets("SNo Log")
wkb.Activate
ws.Activate
ActiveWorkbook.Worksheets("Data Entry").sort.SortFields.Clear
ActiveWorkbook.Worksheets("Data Entry").sort.SortFields.Add Key:=Range( _
"A12:A112"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Data Entry").sort
.SetRange Range("A11:N112")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
For r = 12 To lr
If wkb.ws.Cells(r, 1).Value = 1 Then
ws.Cells(r, "B:L").Copy
wkb2.Activate
ws2.Activate
Range("D" & Rows.Count).EndX(x1Up).Offset(1).Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("A" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
Range("A" & Rows.Count).End(xlUp).Offset(0).Select
Selection.Copy
wkb.Activate
ws.Cells(r, 13).Value.Paste
End If
If wkb.ws.Cells(r, 1).Value = 0 Then
ws.Cells(4, 9).Select
ActiveCell.FormulaR1C1 = "Serial No. Issue complete for this OA"
End If
Range("F5").Select
Next r
Any help would be greatly appreciated as it always is. I've tried to set variables, but cannot get them to work on bits of my code due to object errors so had to go back to the code I know works. But this only does for fixed ranges, which I will not have in this workbook.
Per my comments, you don't need to sort your data, or use Activate. Using Range("D" & Rows.Count).EndX(x1Up).Offset(1) was going in the right direction except you needed to remove the X in EndX. Also, the portion of code below does not make any sense. So you need to clarify what you want, to include an example of the outcome, if needed.
Range("A" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
Range("A" & Rows.Count).End(xlUp).Offset(0).Select
Selection.Copy
wkb.Activate
ws.Cells(r, 13).Value.Paste
End If
If wkb.ws.Cells(r, 1).Value = 0 Then
ws.Cells(4, 9).Select
ActiveCell.FormulaR1C1 = "Serial No. Issue complete for this OA"
End If
Range("F5").Select
The best way to copy a range is to copy the complete range, not line-by-line. The code below will hide any rows from Range("A12:A112") that do not have a "1" in column A. It will then copy the visible cells in the range using SpecialCells(xlCellTypeVisible) and paste to the first empty cell in ws2.Column(4). It then makes all the rows that were hidden visible again. This code will work if your workbook and worksheet variables are correct.
Dim ws As Worksheet
Dim wkb2 As Workbook
Dim ws2 As Worksheet
Dim Rng As Range
Set ws = ThisWorkbook.Worksheets("Data Entry")
Set wkb2 = Workbooks.Open("\\srveurfcl03.nov.com\IS-GBR-GLBISETNRegister$\Serial No Trial\Serialisation Log.xlsx")
Set ws2 = wkb2.Worksheets("SNo Log")
For Each cell In ws.Range("A12:A112")
If cell.Value <> "1" Then
cell.EntireRow.Hidden = True
End If
Next cell
Set Rng = ws.Range("A12:A112").SpecialCells(xlCellTypeVisible)
Rng.Copy Destination:=ws2.Cells(Rows.Count, 4).End(xlUp).Offset(1)
ws.Range("A12:A112").EntireRow.Hidden = False

Copy and sort data from one sheet to another, based on cell values

I have searched a lot of similar topics and have had some help but I cant find a way to do what I need (probably because of my limited experience with excel and vba), so here it goes:
I have a (Source)sheet 'offers' , which is populated daily, with the columns below:
columns: b c d e f g
header: offercode issue dt worktype customer sent dt confirmation dt
xxx.xx. 1/1/14 MI john 1/1/14 3/1/14
aaa.aa. 1/1/14 MD bob 2/1/14
bbb.bb 2/1/14 SI peter 2/1/14 3/1/14
what I need is to copy all rows that get a confirmation date (not blank) in another sheet"production orders"(destination)
where I generate production order codes and input other kind of data :
columns: b c d e f g
header: offercode productioncode worktype start end confirmation dt
xxx.xx. 1/1/14 MI 5/1/14 3/1/14
bbb.bb 2/1/14 SI 6/1/14 3/1/14
note that column b and b & c contain formulas (generates offer codes)
my problem is that data is populated daily, and offers(Source Sheet) should be sorted by issue date and once they get confirmed(input confirmation date->non blank) they should be copied in the other sheet but sorted (or polulate the next empty row) by confirmation date eg:
columns: b c d e f g
header: offercode productioncode worktype start end confirmation dt
xxx.xx. XX.XXX. MI 5/1/14 3/1/14
bbb.bb BB.BBB SI 6/1/14 3/1/14
aaa.aa. AA>AAA MD 4/1/14
another issue is how often or when is the second (Destination Sheet) list refreshs with new data, my guess is that a control button click after every data entry instance would work (and make sure that the list is up to date)
thank you in advance,
Angelos
So, this is what is working for me right now, its all based on #simoco's code:
I am checking in it for operational consistency, but the code works fine.
It copies and pastes only the columns of (my) interest where I need it and then sorts a dynamic range.
Sub copycolumnsonly()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim lastrow1 As Long
Dim lastrow2 As Long
Dim j As Long
Dim i As Long
Dim rng As Range
'set correct name of the sheet with your data'
Set sh1 = ThisWorkbook.Worksheets("ÐÑÏÓÖÏÑÅÓ")
'set correct name of the sheet where you need to paste data'
Set sh2 = ThisWorkbook.Worksheets("ÅÍÔÏËÅÓ ÐÁÑÁÃÙÃÇÓ")
'determining last row of your data in file ÁÁÁÁÁÁÁÁ.xlsx'
lastrow1 = sh1.Range("C" & sh1.Rows.Count).End(xlUp).Row
'determining last row of your data in file ÂÂÂÂÂÂÂÂ.xls'
lastrow2 = sh2.Range("F" & sh2.Rows.Count).End(xlUp).Row
'clear content in sheet2
sh2.Range("F11:F" & lastrow2).ClearContents
sh2.Range("G11:G" & lastrow2).ClearContents
sh2.Range("N11:N" & lastrow2).ClearContents
'suppose that in sheet2 data starts from row #11
j = 11
For i = 0 To lastrow1
Set rng = sh1.Range("G11").Offset(i, 0)
'check whether value in column D is not empy
If Not (IsNull(rng) Or IsEmpty(rng)) Then
sh1.Range("B" & i + 11).Copy
sh2.Range("F" & j).PasteSpecial xlPasteValues
sh1.Range("g" & i + 11).Copy
sh2.Range("G" & j).PasteSpecial xlPasteValues
sh1.Range("K" & i + 11).Copy
sh2.Range("N" & j).PasteSpecial xlPasteValues
j = j + 1
End If
Next i
Application.CutCopyMode = False
'sorting the new list, recorded macro tweaked to use a dynamic named range
ActiveWorkbook.Worksheets("ÅÍÔÏËÅÓ ÐÁÑÁÃÙÃÇÓ").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("ÅÍÔÏËÅÓ ÐÁÑÁÃÙÃÇÓ").Sort.SortFields.Add Key:=Range( _
"G:G"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("ÅÍÔÏËÅÓ ÐÁÑÁÃÙÃÇÓ").Sort
.SetRange Range("PRODUCTIONORDERS")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
this is what I have come up with as a completly different approach,
I would greatly appreciate it if you could check it for error handling, or invalid input from users etc
(see comments in code)
`
Sub ActiveToLastRow()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim activerow As Long
Dim lastrow2 As Long
Dim rng As Range
Dim confirmation As Range
'set correct name of the sheet with your data
Set sh1 = ThisWorkbook.Worksheets("ÐÑÏÓÖÏÑÅÓ")
'set correct name of the sheet where you need to paste data
Set sh2 = ThisWorkbook.Worksheets("ÅÍÔÏËÅÓ ÐÁÑÁÃÙÃÇÓ")
'making sure the user selects the correct offercode via inputbox to get its rownumber --> see activerow variable
Set rng = Application.InputBox("dialeje prosfora", "epilogh prosforas", Type:=8)
'getting the information(confirmation date) via input box form the user
Dim TheString As String
Dim TheDate As Date
TheString = Application.InputBox("Enter A Date", "epibebaiwsh anathesis")
If IsDate(TheString) Then
TheDate = DateValue(TheString)
Else
MsgBox "Invalid date"
'need to end sub if user input is invalid
End If
'determining active row of your data in file ÁÁÁÁÁÁÁÁ.xlsx where data input occurs <-- user input via 1st input box
activerow = rng.Row
Set confirmation = sh1.Range("G" & activerow)
confirmation.Value = TheDate
'determining last row of your data in file ÂÂÂÂÂÂÂÂ.xls'
lastrow2 = sh2.Range("F" & sh2.Rows.Count).End(xlUp).Row
'determining what to copy and where
sh1.Range("B" & activerow).Copy
sh2.Range("F" & lastrow2 + 1).PasteSpecial xlPasteValues
sh1.Range("g" & activerow).Copy
sh2.Range("G" & lastrow2 + 1).PasteSpecial xlPasteValues
sh1.Range("K" & activerow).Copy
sh2.Range("N" & lastrow2 + 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
'activating destination sheet for testing purposes
sh2.Activate
End Sub`
It looks like you simply need to copy over only those rows with a value in the "Confirmation Date" column - if I read the above correctly.
If the sheet with the daily updates is called "First", and the resultant sheet with only the confirmed orders is called "Second", the following should do it...
Sub Macro1()
'
' Macro1 Macro
'
'
lastRow = 10 ' hard coded here; use whatever technique to get real value.
'Copy over the headers to the new sheet
Sheets("First").Select
Rows("1:1").Select
Selection.Copy
Sheets("Second").Select
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Columns("A:F").ColumnWidth = 9
Columns("G:G").ColumnWidth = 12
Sheets("First").Select
' Range("G1").Select
Confirm_Count = 0
For Row = 1 To lastRow
If Len(Range("G1").Offset(Row, 0)) > 1 Then
Rows(Row + 1).Select
Selection.Copy
Sheets("Second").Select
Confirm_Count = Confirm_Count + 1
Range("A1").Offset(Confirm_Count, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets("First").Select
End If
Next Row
End Sub

Resources