Copy rows to another workbook - excel

This code worked once and then stopped. It runs with no action or errors.
I would like if column "a" of the "export" sheet has a yes to copy the cells from B to J to the next clear line in workbook MOSTEST sheet1 (named 11.2022).
Sub DateSave()
Dim LastRow As Integer, i As Integer, erow As Integer
LastRow = Worksheets("EXPORT").Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To LastRow
If Cells(i, 1).Value = "YES" Then
Range(Cells(i, 2), Cells(i, 10)).Select
Selection.Copy
Workbooks.Open Filename:="F:\Orders\MOSTEST.xlsx"
Worksheets("11.2022").Select
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.CutCopyMode = False
End If
Next i
End Sub
If changed the "Worksheets("11.2022").Select" to sheet1 which I would prefer as I wouldn't have to change it every month.

You should try to avoid using select, see other post
I adjusted your code where needed, I'm still trying to figure out best practice (i.e. it would be better adding the cell ranges to a range variable and then pasting them in one go but I'm not quite there yet) when it comes to minimizing code so if others can do better, feel free :)
Sub DateSave()
Dim LastRow As Long, i As Long, erow As Long
Dim wsStr As String
Dim ws As Worksheet, wsC As Worksheet
Dim wb As Workbook, wbM As Workbook
LastRow = Worksheets("EXPORT").Range("A" & Rows.Count).End(xlUp).Row
Set wb = ActiveWorkbook
Set wsC = wb.Sheets("EXPORT")
Workbooks.Open Filename:="F:\Orders\MOSTEST.xlsx" 'Don't keep opening and saving/closing your workbook per copy, that would heavily increase runtime
Set wbM = Workbooks("MOSTEST.xlsx")
wsStr = Month(Date) & "." & Year(Date)
Set ws = wbM.Worksheets(wsStr) 'If your currentmonth will always be the first sheet then you can use wbM.Sheets(1)
erow = ws.Cells(Rows.Count, 1).End(xlUp).Row
wb.Activate
For i = 1 To LastRow
If wsC.Cells(i, 1).Value = "YES" Then
erow = erow + 1
wsC.Range(wsC.Cells(i, 2), wsC.Cells(i, 10)).Copy 'avoid select
ws.Range("A" & erow).PasteSpecial xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
Next i
wbM.Save
wbM.Close
Application.CutCopyMode = False
End Sub
If you have questions, feel free to ask!

Related

Issue with an Excel macro not copying data form 1 file to another

I have an excel macro that is running correctly on over 10 pc's.
On 1 pc it does not run correctly. It does not error out, just seems to not run to completion. All machines are running windows 10.
I have included the code below.
Fairly simple. Copies from "Follow_Up" sheet in the source file to "Sheet1" in the destination file.
It seems to stop just after it activates "Sheet1"
Sub copydata1()
Dim wbSrc As Workbook, wbDest As Workbook
Dim rngSrc As Range
Dim j As Integer
Dim i As Integer
Set wbSrc = ActiveWorkbook
Sheets("Follow_Up").Activate
Workbooks.Open "G:\Estimating Templates\Bid List_Lee.xlsm"
Set wbDest = ActiveWorkbook
Sheets("Sheet1").Activate
-----seems to stop here---------
Dim unusedRow As Long
unusedRow = Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).Row
j = ActiveCell.Row
j = unusedRow
MsgBox j
wbSrc.Activate
Sheets("Follow_Up").Select
Range("L151").Select
ActiveCell.FormulaR1C1 = "=CELL(""filename"")"
Range("M151").Select
Range("A151:Q151").Select
Selection.Copy
wbDest.Activate
Sheet1.Cells(j, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheet1.Cells(j, 1) = Sheet1.Cells(j, 14)
Sheet1.Cells(j, 17).Select
ActiveCell.FormulaR1C1 = "=HYPERLINK(RC[-1])"
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 1
Range("A20").Select
wbSrc.Activate
Sheets("Follow_Up").Select
Range("L151").Select
ActiveCell.FormulaR1C1 = "=CELL(""filename"")"
Range("M151").Select
wbSrc.Activate
Sheets("Summary").Select
End Sub

Format worksheets 5 and on, then copy&paste that info into "Sheet3" with source width and format

I am currently try to make a code that will format sheets 5 and on to module one's code and then have the program copy all the information in each of those newly formatted sheets and paste them into "sheet3" with original width and format.
I have tried the "for each" and "integer" functions but can't seem to get 'the program to move past "sheet5".
This sub is suppose to go through all of the sheets and and 'format them to my needs:
Sub TEST2()
Dim ws As Worksheet
Dim wsDest As Worksheet
Dim LastRow As Long
Set wsDest = Sheets("sheet3")
For Each ws In ActiveWorkbook.Sheets
If ws.Name <> wsDest.Name And _
ws.Name <> "sheet1" And _
ws.Name <> "sheet2" And _
ws.Name <> "sheet4" Then
'code here
Columns.Range("A:A,B:B,H:H,I:I").Delete
Columns("A").ColumnWidth = 12
Columns("B").ColumnWidth = 17
Columns("C").ColumnWidth = 10
Columns("D").ColumnWidth = 85
Columns("E").ColumnWidth = 17
ActiveSheet.Range("D:D").WrapText = True
ActiveSheet.Range("F:F").EntireColumn.Insert
ActiveSheet.Range("F1").Formula = "Product ID"
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Range("F2:F" & LastRow).Formula = "=$G$2"
ActiveSheet.Range("F2").Copy
Range("F2:F" & LastRow).PasteSpecial Paste:=xlPasteValues
End If
Next ws
End Sub
This sub is meant to go to "sheet5" first and paste it into '"sheet3", than the second half of the sub should start at "sheet6" and go on 'until the end of the work sheets and then copy & paste onto "sheet3" with 'original width.
Sub Test1()
Dim sht As Worksheet
Dim LastRow As Long
Dim WS_Count As Integer
Dim I As Integer
Sheets("Sheet5").Select
Application.CutCopyMode = False
Application.Run "PERSONAL.XLSB!Module1.Del_move_insert_colmuns"
Range("G2").Select
ActiveCell.Offset(0, -1).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet3").Select
Range("A1").Select
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.Range("D:D").WrapText = True
WS_Count = ActiveWorkbook.Worksheets.Count
' Begin the loop
For I = 5 To WS_Count
'code here
Sheets("Sheet6").Select
Application.Run "PERSONAL.XLSB!Module1.Del_move_insert_colmuns"
Application.CutCopyMode = False
Range("G2").Select
ActiveCell.Offset(0, -1).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToLeft)).SelectApplication.CutCopyMode = False
Selection.Copy
Sheets("Sheet3").Select
Range("A1").Select
'crtl shift + down
Selection.End(xlDown).Select
'moves down one cell to paste
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Next I
End Sub
What im getting right now is it does "sheet5" and "sheet6" fine,but after that doesn't format and on sheet there all i get is a bunch of columns with top labeled as product ID and a bunch of 0's.
A big part of your problem is that most of your code is "assuming" that you are working with a certain worksheet when you're really working with the ActiveSheet. As an example in your TEST2 routine, you're looping through all of the worksheets in the workbook, skipping certain sheets. This part works fine. But when you want to format the other sheets, you're really only working with whatever worksheet is currently active. To fix this, you should make a habit of making sure all of your Worksheet, Range, and Cells reference are always fully qualified. So then your code works like this:
ws.Columns.Range("A:A,B:B,H:H,I:I").Delete
ws.Columns("A").ColumnWidth = 12
ws.Columns("B").ColumnWidth = 17
ws.Columns("C").ColumnWidth = 10
ws.Columns("D").ColumnWidth = 85
ws.Columns("E").ColumnWidth = 17
ws.Range("D:D").WrapText = True
ws.Range("F:F").EntireColumn.Insert
ws.Range("F1").Formula = "Product ID"
LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
ws.Range("F2:F" & LastRow).Formula = "=$G$2"
ws.Range("F2").Copy
ws.Range("F2:F" & LastRow).PasteSpecial Paste:=xlPasteValues
Notice how every single reference is locked to the same worksheet. You can take a shortcut though, by using the With statement. But you must make sure that each reference has the . in front of it to lock it back to the With object, like this:
With ws
.Columns.Range("A:A,B:B,H:H,I:I").Delete
.Columns("A").ColumnWidth = 12
.Columns("B").ColumnWidth = 17
.Columns("C").ColumnWidth = 10
.Columns("D").ColumnWidth = 85
.Columns("E").ColumnWidth = 17
.Range("D:D").WrapText = True
.Range("F:F").EntireColumn.Insert
.Range("F1").Formula = "Product ID"
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("F2:F" & LastRow).Formula = "=$G$2"
.Range("F2").Copy
.Range("F2:F" & LastRow).PasteSpecial Paste:=xlPasteValues
End With
For the rest of your code, you can make improvements by avoiding the use of Select and Activate. Consider also the tips discussed in this article that will give you excellent guidance.

Compiler error 'Next without For' - can't understand why

This is a simple For ... Next so why am I getting the error, is it related to the function somehow?
The macro I supposed to find a specific worksheet within a large workbook, get some data and copy it to a separate workbook named after the worksheet. Most of this came from mw recording a macro with changes were necessary.
Dim wbThisWB As Workbook
Dim LastRow As Long
Dim WSName As String
Dim lRow As Long
Workbooks.Open Filename:= _
"\\Shenetapp01\itt viability and intervention\Assurance Work AY 17-18\AGR\Test\16-17 EY Trainees test.xls"
LastRow = wbThisWB.Worksheets("Sheet1").Cells(Row.Count, 1).End(xlUp).Row
For I = 1 To LastRow
WSName = wbThisWB.Worksheets("Sheets1").Cells(I, 1)
If sheetExists(WSName, wbThisWB) Then
MsgBox "Sheet found:" & WSName
lRow = Cells(Rows.Count, 1).End(xlUp).Row
ActiveSheet.Range("C2", "M" & lRow).Copy
Workbooks.Open Filename:="\\Shenetapp01\itt viability and intervention\Assurance Work AY 17-18\AGR\Test\" & WSName & " 17-18 AGR.xlsx"
Sheets("EY 17-18 Starters").Select
Range("C6").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWorkbook.Save
ActiveWindow.Close
Next I
End Sub
Function sheetExists(sheetToFinad As String, wbThisWB As Workbook) As Boolean
sheetExists = False
For Each Sheet In wbThisWB.Worksheets
If sheetToFind = Sheet.Name Then
sheetExists = True
Exit Function
End If
Next Sheet
End Function

Paste copied stuff at the very end of a row

I have a form where you fill stuff in and a specific part of it should be copied to another sheet at the end of the list.
With Sheets("Sheet1")
If Application.WorksheetFunction.CountA(.Columns(2)) <> 0 Then
lastrow = .Cells(rows.Count, "B").End(xlUp).Row
Else
lastrow = 1
End If
.Cells(lastrow + 1, "B") = "my new value"
End With
I have this code to find the last row and paste/write "my new value" in it.
But i need that it pastes more than just one cell. I just need that it selects that part where it writes "my new value" in. I should be able to do the rest
I'm now using the code below. But it still copies stuff from the sheet "Tabelle3" but it should copy the stuff from the sheet "Tabelle2"
Private Sub CommandButton1_Click()
Dim lastRow As Long
With Sheets("Tabelle3")
If Application.WorksheetFunction.CountA(.Columns(1)) <> 0 Then
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1 '<~~ Add 1 here and not as you are doing
Else
lastRow = 1
End If
Sheets("Tabelle2").Select
Range("B85:S85").copy
Sheets("Tabelle3").Select
'~~> Paste special
.Range("C" & lastRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End With
End Sub
You have to find the last empty row and then simply do a paste or pastespecial as shown below.
Sub Sample()
Dim lastRow As Long
With Sheets("Sheet1")
If Application.WorksheetFunction.CountA(.Columns(2)) <> 0 Then
lastRow = .Cells(Rows.Count, "B").End(xlUp).Row + 1 '<~~ Add 1 here and not as you are doing
Else
lastRow = 1
End If
Range("Z10:Z100").Copy
'~~> Paste special
.Range("B" & lastRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End With
End Sub
The above code will copy the range "Z10:Z100" and do a pastespecial on the next available row in Col B. If you do not want to do a pastespecial and want to do a direct paste then see this
Sub Sample()
Dim lastRow As Long
With Sheets("Sheet1")
If Application.WorksheetFunction.CountA(.Columns(2)) <> 0 Then
lastRow = .Cells(Rows.Count, "B").End(xlUp).Row + 1 '<~~ Add 1 here and not as you are doing
Else
lastRow = 1
End If
Range("Z10:Z100").Copy .Range("B" & lastRow)
End With
End Sub

Excel Macro Copy Selection area and Paste

This is what I have:
I am trying to get excel to copy only the cells that i have selected and pasted on the next blank line in another spreadsheet.
But in the code below, it fixed the range of cell being copied. How should i change my code so that it can be a dynamic range?
Sub CopyPaste()
Range("A6:E6").Select
Selection.Copy
Sheets("Sheet2").Select
lMaxRows = Cells(Rows.Count, "A").End(xlUp).Row
Range("A" & lMaxRows + 1).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
lMaxRows = Cells(Rows.Count, "A").End(xlUp).Row
Range("A" & lMaxRows + 1).Select
End Sub
Remove the statement
Range("A6:E6").Select
This statement selects the fixed range.
Try this
Sub CopyPaste()
Dim sht As Worksheet
Dim rngTarget As Range
Dim lMaxRows As Long
Selection.Copy
Set sht = Sheets("Sheet2")
lMaxRows = sht.Cells(Rows.Count, "A").End(xlUp).Row
Set rngTarget = sht.Range("A" & lMaxRows + 1)
rngTarget.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
lMaxRows = sht.Cells(Rows.Count, "A").End(xlUp).Row
sht.Activate
sht.Range("A" & lMaxRows + 1).Select
End Sub
I have rewritten the code to specify exactly which cells and ranges are used. If not, it will apply selections on the sheet that is open (active) at that moment.
In my experience, using .Select is error-prone so I try to avoid it as much as possible.

Resources