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
Related
as all i have a repeating work which i need to do on daily basis.
as i am a complete noob and my complete macro list which i have created is by reading here maybe you could help me out with one macro
is there a possiblity the macro from below to change that it will apply for all already open workbooks ?
Sub copyDown()
Dim myCount As Double
myCount = WorksheetFunction.CountA(Range("B:B"))
Range("ab2:ad" & myCount).FillDown
End Sub
Sub columnA()
Dim myfirstRow, myLastrow As Integer
myfirstRow = WorksheetFunction.CountA(Range("A:A")) + 1
myLastrow = WorksheetFunction.CountA(Range("B:B"))
Range("a" & myfirstRow & ":a" & myLastrow).Formula = "=TODAY() - 1"
Range("a" & myfirstRow & ":a" & myLastrow).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
End Sub
both sub i need to do in 5 files where each file have 2 specific sheets
in theory i know i could arrange it a bit different but my original macro have around 1600 lines and i am afraid to touch the running macro which i have build now for 2weeks :S
thank you all
This is how to create a separate sub that will find each workbook then call your original sub, passing it the worksheet it should work on.
I've only done it for "CopyDown", but it's exactly the same process.
Option Explicit
Sub Iterate_Workbooks()
Dim WB As Workbook
For Each WB In Application.Workbooks
' This is a way to exclude open workbooks from your search
' OR remove the "not" to include withbooks with only certain
' text in their name. "*" is wildcard, see some examples:
'If Not WB.Name Like "Master*" Then
'If WB.Name Like "FillerBook # *" Then
If Not WB.Name Like "*.xlsm" Then
Call copyDown(WB.Worksheets(1))
End If
Next WB
End Sub
Sub copyDown(WS As Worksheet)
Dim myCount As Double
With WS
myCount = WorksheetFunction.CountA(.Range("B:B"))
.Range("ab2:ad" & myCount).FillDown
End With
End Sub
You can create a function that would go through all the open workbooks and from each work book it will go through all the sheets and match the name of the sheets to call your subroutines columnA and copyDown by passing the sheet reference, hope this helps!
Sub ProcessAllWorkbooks()
Dim WB As Workbook, WS As Worksheet
For Each WB In Workbooks
For Each WS In WB.Sheets
If UCase(WS.Name) = "WHATEVER_NAME_OF_COPY_DOWN_SHEET_IN_UPPERCASE" Then
Call copyDown(WS)
ElseIf UCase(WS.Name) = "WHATEVER_NAME_OF_COLUMNa_SHEET_IN_UPPERCASE" Then
Call columnA(WS)
End If
Next
Next
End Sub
Sub copyDown(processWS As Worksheet)
Dim myCount As Double
With processWS
.Activate
.Range("B1").Select
myCount = WorksheetFunction.CountA(Range("B:B"))
Range("ab2:ad" & myCount).FillDown
End With
End Sub
Sub columnA(processWS As Worksheet)
Dim myfirstRow, myLastrow As Integer
With processWS
.Activate
.Range("A1").Select
myfirstRow = WorksheetFunction.CountA(Range("A:A")) + 1
myLastrow = WorksheetFunction.CountA(Range("B:B"))
Range("a" & myfirstRow & ":a" & myLastrow).Formula = "=TODAY() - 1"
Range("a" & myfirstRow & ":a" & myLastrow).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
End With
End Sub
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!
I have a worksheet (sheet2) which contains a vlookup function with changing values in certain cells to refresh data. I want to copy any changed values to another workbook.
Sub Copy_file()
Dim xWs As Worksheet
Dim Rng As Range
Set Rng = Range("C6:M124")
Application.Workbooks.Add
Set xWs = Application.ActiveSheet
Rng.Copy
xWs.Cells(2, 2).PasteSpecial Paste:=xlPasteValues
xWs.Cells(2, 2).PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
xWs.Cells(2, 2).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
xWs.Cells(2, 2).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End Sub
Every time the code runs it creates a new workbook.
I need to modify it so that I can add a new workbook with a specific name and the copied data is pasted in sheet1 only when the macro runs for the first time.
On subsequent runs the copied data should be pasted in the next sheet (e.g. Sheet2, Sheet3, Sheet4,... etc.) in the single workbook.
Please, try the next code:
Sub Copy_file()
Dim xWs As Worksheet, Rng As Range, wb As Workbook, wsMark As Worksheet
Dim wbFullName As String, wbName As String, lastR As Long
wbName = "MyWorkbook.xlsx"
wbFullName = ThisWorkbook.Path & "\" & wbName
Set Rng = Range("C6:M124") 'the range is set in the active workbook
'if the one keeping the code, please state it
'and the range will be fully qualified
If dir(wbName) = "" Then 'if the necessary workbook does not exist
Set wb = Application.Workbooks.Add 'create it
wb.saveas wbName 'name the newly created workbook
Set wsMark = wb.Sheets(wb.Sheets.count)
wsMark.Name = "UsedSheets" 'name the last sheet keeping copying order
End If
If wb Is Nothing Then 'if not created above, but exists:
On Error Resume Next
Set wb = Workbooks(wbName) 'check if it is open
Set wsMark = wb.Worksheets("UsedSheets") 'set the sheet keeping copying order
On Error GoTo 0
End If
'if not open, open it:
If wb Is Nothing Then
Set wb = Workbooks.Open(wbFullName)
Set wsMark = wb.Worksheets("UsedSheets") 'set the sheet keeping copying order
End If
lastR = wsMark.Range("A" & wsMark.rows.count).End(xlUp).row 'last used row in the sheet
If lastR > 1 Then
If CLng(wsMark.Range("A" & lastR).value) < (wb.Sheets.count - 2) Then
Set xWs = wb.Sheets(CLng(wsMark.Range("A" & lastR).value + 1))
wsMark.Range("A" & lastR + 1).value = xWs.Index
Else
Set xWs = wb.Sheets.Add(Before:=wsMark)
wsMark.Range("A" & lastR + 1).value = xWs.Index
End If
Else
Set xWs = wb.Sheets(1): wsMark.Range("A" & lastR + 1).value = 1
End If
Rng.copy
With xWs.cells(2, 2)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End With
End Sub
Edited:
Please, test the next variant. It open a new workbook, first time you run the code and uses it until you close it. You must manually save it, when finished the copying process...
Sub Copy_file()
Dim xWs As Worksheet, Rng As Range, wb As Workbook, wsMark As Worksheet
Dim wbFullName As String, wbName As String, lastR As Long
wbName = "MyWorkbook.xlsx"
wbFullName = ThisWorkbook.Path & "\" & wbName
Set Rng = Range("C6:M124")
If dir(wbName) = "" Then 'if the necessary workbook does not exist
Set wb = Application.Workbooks.Add 'create it
wb.saveas wbName 'name the newly created workbook
Set wsMark = wb.Sheets(wb.Sheets.count)
wsMark.Name = "UsedSheets" 'name the last sheet keeping copying order
End If
If wb Is Nothing Then 'if not created above, but exists:
On Error Resume Next
Set wb = Workbooks(wbName) 'check if it is open
Set wsMark = wb.Worksheets("UsedSheets") 'set the sheet keeping copying order
On Error GoTo 0
End If
'if not open, open it:
If wb Is Nothing Then
Set wb = Workbooks.Open(wbFullName)
Set wsMark = wb.Worksheets("UsedSheets") 'set the sheet keeping copying order
End If
lastR = wsMark.Range("A" & wsMark.rows.count).End(xlUp).row 'last used row in the sheet
If lastR > 1 Then
If CLng(wsMark.Range("A" & lastR).value) < wb.Sheets.count - 1 Then
Set xWs = wb.Sheets(CLng(wsMark.Range("A" & lastR).value + 1))
wsMark.Range("A" & lastR + 1).value = xWs.Index
Else
Set xWs = wb.Sheets.Add(Before:=wsMark)
wsMark.Range("A" & lastR + 1).value = xWs.Index
End If
Else
Set xWs = wb.Sheets(1): wsMark.Range("A" & lastR + 1).value = 1
End If
Rng.copy
With xWs.cells(2, 2)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End With
End Sub
Sub Copy_file1()
Dim xWs As Worksheet, Rng As Range, wb As Workbook
Dim w As Workbook, wsMark As Worksheet, lastR As Long
Set Rng = Range("C6:M124") 'if active sheet belongs to the workbook keeping this code
'it should be adapted to fully qualify the range
If wb Is Nothing Then 'check if wb exists but it losts the reference because of an error:
For Each w In Workbooks 'iterate between open workbooks:
If w.Sheets(w.Sheets.count).Name = "UsedSheets" Then
Set wb = w
Set wsMark = wb.Worksheets("UsedSheets"): Exit For
End If
Next w
End If
'if wb does not exist:
If wb Is Nothing Then
Set wb = Application.Workbooks.Add 'open a new workbook and set it
Set wsMark = wb.Sheets(wb.Sheets.count) 'set the last sheet like the one to keep copying order
wsMark.Name = "UsedSheets"
End If
If left(Rng.Parent.Parent.Name, 4) = "Book" Then 'if, by mistake, the selection is done on a wb sheet:
MsgBox "The active sheet where ""Rng"" was set belongs to the workbook where to copy..." & vbCrLf & _
"It should be a mistake. Please, select the appropriate sheet!", vbInformation, "Wrong sheet selected.."
Exit Sub
End If
lastR = wsMark.Range("A" & wsMark.rows.count).End(xlUp).row 'last used row in the sheet
If lastR > 1 Then 'for the first time (when wb has been created):
If CLng(wsMark.Range("A" & lastR).value) < wb.Sheets.count - 1 Then
Set xWs = wb.Sheets(CLng(wsMark.Range("A" & lastR).value + 1))
wsMark.Range("A" & lastR + 1).value = xWs.Index
Else 'if is not the first copying time:
Set xWs = wb.Sheets.Add(Before:=wsMark)
wsMark.Range("A" & lastR + 1).value = xWs.Index
End If
Else
Set xWs = wb.Sheets(1): wsMark.Range("A" & lastR + 1).value = 1
End If
Rng.copy
With xWs.cells(2, 2)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End With
End Sub
Try:
Sub Copy_file()
Application.ScreenUpdating = False
Dim xWs As Worksheet
Static WB As Workbook ' static variables stores its values between proc calls
If WB Is Nothing Then ' check if a certain workbook exists. if no, create it
Set WB = Workbooks.Add
Else
WB.Worksheets.Add after:=WB.Sheets(WB.Sheets.Count) ' create the next WS
End If
Set xWs = ActiveSheet
ThisWorkbook.Sheets("Sheet2").Range("C6:M124").Copy
With xWs.Cells(2, 2)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End With
Application.ScreenUpdating = True
End Sub
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.
The following code loops within a sheet.
I want to loop through all sheets in my workbook except for one sheet labeled "Summary".
For i = 2 To LR
If Abs(Range("J" & i)) > 0 Then
Range("A" & i & ":J" & i).Copy
Sheets("Sheet1").Range("A" & k).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
k = k + 1
Else
End If
Next i
Please try something like this
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Summary" Then
'Your code here
End If
Next