I'm using the following code to copy from an excel file starting with "Backorder Details":
Sub INSERT()
Dim Wb1 As Workbook, wb2 As Workbook, wB As Workbook
Dim rngToCopy As Range
Dim countEND As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Sheets("RAW_DATA").Select
Worksheets("RAW_DATA").Range("A3:CA45000").ClearContents
If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilter.ShowAllData
For Each wB In Application.Workbooks
If Left(wB.Name, 17) = "Backorders Detail" Then
Set Wb1 = wB
Exit For
End If
Next
If Not Wb1 Is Nothing Then
Set wb2 = ThisWorkbook
With Wb1.Sheets(2)
Set rngToCopy = .Range("A3:BX3", .Cells(.Rows.Count, "A").End(xlUp))
End With
wb2.Sheets("RAW_DATA").Range("A3:BX3").Resize(rngToCopy.Rows.Count).Value = rngToCopy.Value
End If
With wb2.Sheets("RAW_DATA")
countEND = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("BY3:BY" & countEND).Formula = "=IFERROR(IF(AND(VLOOKUP(VALUE(AS3);BG_DATA!A:A;1;FALSE)=(VLOOKUP(VALUE(AS3);BG_DATA!A:A;1;FALSE));(AF3>0));"""";""x"");""x"")" 'Check
.Range("BZ3:BZ" & countEND).Formula = "=VLOOKUP(VALUE(AS3);BG_DATA!A:I;9;FALSE)" 'Vendor'
.Range("CA3:CA" & countEND).Formula = "=VLOOKUP(VALUE(AS3);BG_DATA!A:J;10;FALSE)" 'Planner
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "DONE!"
End Sub
I copied this function from another excel file I've made. It worked pretty good. But for some reason the following part is giving me an error now:
With wb2.Sheets("RAW_DATA")
countEND = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("BY3:BY" & countEND).Formula = "=IFERROR(IF(AND(VLOOKUP(VALUE(AS3);BG_DATA!A:A;1;FALSE)=(VLOOKUP(VALUE(AS3);BG_DATA!A:A;1;FALSE));(AF3>0));"""";""x"");""x"")" 'Check
.Range("BZ3:BZ" & countEND).Formula = "=VLOOKUP(VALUE(AS3);BG_DATA!A:I;9;FALSE)" 'Vendor'
.Range("CA3:CA" & countEND).Formula = "=VLOOKUP(VALUE(AS3);BG_DATA!A:J;10;FALSE)" 'Planner
End With
Run-time error 1004 - Application-defined or object defined error.
I googled this but didn't find a solution. Excel file was an XLSX and is an XLSM now. Can someone please tell what the problem is?
You are using semicolon ; as a delimiter in your formula, but the delimiter depends on the localization of your workbook. Use comma , instead:
With wb2.Sheets("RAW_DATA")
countEND = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("BY3:BY" & countEND).Formula = "=IFERROR(IF(AND(VLOOKUP(VALUE(AS3),BG_DATA!A:A,1,FALSE)=(VLOOKUP(VALUE(AS3),BG_DATA!A:A,1,FALSE)),(AF3>0)),"""",""x""),""x"")" 'Check
.Range("BZ3:BZ" & countEND).Formula = "=VLOOKUP(VALUE(AS3),BG_DATA!A:I,9,FALSE)" 'Vendor'
.Range("CA3:CA" & countEND).Formula = "=VLOOKUP(VALUE(AS3),BG_DATA!A:J,10,FALSE)" 'Planner
End With
Alternatively you could use .FormulaLocal instead of .Formula, but it will work only in the workbooks where localization defines semicolon as the delimiter.
Related
I am trying to make a macro where I separate my tabs (one from each client) into new excel files and then also filter, copy and paste (from a sheet called database) in each of those excel files just created the informations regarding each client.
When I try to run the code, it separate the tabs just as expected, but it does not copy and paste the information from my database sheet. I got the following error: "Application-defined or object-definied error" for the line "For Each x In Workbk.Sheets(sht).Range([AA2], Cells(Rows.Count, "AA").End(xlUp))"
How can I fix it?
Sub Separar_guias()
Dim xPath As String
xPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
xWs.Copy
Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xlsx"
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub filter()
Application.ScreenUpdating = False
Dim x As Range
Dim rng As Range
Dim rng1 As Range
Dim last As Long
Dim sht As String
Dim newBook As Excel.Workbook
Dim Workbk As Excel.Workbook
'Specify sheet name in which the data is stored
sht = "database"
'Workbook where VBA code resides
Set Workbk = ThisWorkbook
'change filter column in the following code
last = Workbk.Sheets(sht).Cells(Rows.Count, "AA").End(xlUp).Row
With Workbk.Sheets(sht)
Set rng = .Range("A1:T" & last)
End With
Workbk.Sheets(sht).Range("AA1:AA" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True
' Loop through unique values in column
For Each x In Workbk.Sheets(sht).Range([AA2], Cells(Rows.Count, "AA").End(xlUp))
With rng
.AutoFilter
.AutoFilter Field:=27, Criteria1:=x.Value
.SpecialCells(xlCellTypeVisible).Copy
'Add New Workbook in loop
Set newBook = Workbooks.Add(xlWBATWorksheet)
newBook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value
newBook.Activate
ActiveSheet.Paste
End With
'Save new workbook
newBook.SaveAs x.Value & ".xlsx"
'Close workbook
newBook.Close SaveChanges:=False
Next x
' Turn off filter
Workbk.Sheets(sht).AutoFilterMode = False
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
End Sub
I have VBA code which creates a new workbook based on a template and saves it with a name based on a list.
I only want the code to create the workbooks IF a statement is true.
See following example:
Sheet "MC_TestSheetGenerator"
The macro ONE_CreateTestsheetWB_TEST_NEW_INST_01 creates new workbooks based on a template called "TEST-NEW-INST-01" and saves the file with the name in col "I" of "MC_TestSheetGenerator".
How can I only do that if the adjacent cell H equals "TEST-NEW-INST-01"?
In this example it should only create two new workbooks as the value is only present in row 3 and 8.
Sub ONE_CreateTestsheetWB_TEST_NEW_INST_01()
Application.DisplayAlerts = False
Dim wb As Workbook, sh1 As Worksheet, lr As Long, rng As Range
Set sh1 = Sheets("MC_TestSheetGenerator") 'Edit sheet name
lr = sh1.Cells(Rows.Count, "I").End(xlUp).Row
Set rng = sh1.Range("I3:I" & lr)
For Each c In rng
Sheets("TEST-NEW-INST-01").Copy 'Edit sheet name
Set wb = ActiveWorkbook
wb.Sheets(1).Range("A3") = c.Value
wb.SaveAs ThisWorkbook.Path & "\" & c.Value & ".xlsx", 51
wb.Close False
Application.DisplayAlerts = True
Next
End Sub
Inside your For loop just add an If statement using property OFFSET :
For Each c In Rng
If c.Offset(0, -1).Value = "TEST-NEW-INST-01" Then
Sheets("TEST-NEW-INST-01").Copy 'Edit sheet name
Set wb = ActiveWorkbook
wb.Sheets(1).Range("A3") = c.Value
wb.SaveAs ThisWorkbook.Path & "\" & c.Value & ".xlsx", 51
wb.Close False
Application.DisplayAlerts = True
End If
Next
Range.Offset property
(Excel)
Also, as advice, I'm pretty sure your Application.DisplayAlerts = True could be outside of the loop.
OFFSET property will be the easiest way to introduce it in your code OR you can change the loop type and loop directly in that column and check the condition after.
Also, I agree with #Foxfire And Burns And Burns, the Application.DisplayAlerts = True should be set outside the loop, preferably at the end of the code/sub.
I have revamped your code, please have a look:
Sub ONE_CreateTestsheetWB_TEST_NEW_INST_01()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim wb As Workbook, wbnew As Workbook
Dim sh1 As Worksheet, lr As Long, rng As Range
Set wb = ThisWorkbook
Set sh1 = wb.Sheets("MC_TestSheetGenerator")
lr = sh1.Cells(Rows.Count, "I").End(xlUp).Row
For i = 3 To lr
If sh1.Range("H" & i).Value2 = "TEST-NEW-INST-01" Then
Set wbnew = Workbooks.Add
wb.Sheets("TEST-NEW-INST-01").Copy Before:=wbnew.Sheets(1)
wbnew.SaveAs wb.Path & "\" & sh1.Range("I" & i).Value2, FileFormat:=51
wbnew.Close
End If
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I'm trying to make the following code more efficient. It currently works as I'd like it to, but it takes a while and I'm wondering if I really need to save the copied workbook before opening it again. I've read that it's good to do that, but it puts a lot of clutter on screen.
Dim ws1 As Worksheet, ws2 As Worksheet
Dim wb1 As Workbook, wb2 As Workbook, NewBook As String
Dim newValue As Variant, i As Long, n As Long
newValue = InputBox("Statement for input box")
folderPath = Application.ActiveWorkbook.path
Set wb1 = ActiveWorkbook
Worksheets(Array("Sheet names")).Copy
With ActiveWorkbook
NewBook = folderPath & "\" & newValue & ".xlsm"
.SaveAs Filename:=NewBook, FileFormat:=xlOpenXMLWorkbookMacroEnabled
.Close SaveChanges:=True
Set wb2 = Workbooks.Open(NewBook)
With wb2
Set ws1 = wb2.Worksheets("Sheet1")
With ws1
lastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
LastRow = .Cells(.Rows.Count, lastColumn).End(xlUp).Row
stopColumn = lastColumn - 12
i = 4
While i <= stopColumn
n = i + 1
ColumnName = ws1.Cells(2, i).Value
If ColumnName <> newValue Then
ws1.Cells(2, i).EntireColumn.Hidden = True
ws1.Cells(2, n).EntireColumn.Hidden = True
End If
ColumnName = ""
i = i + 2
Wend
End With
End With
End With
The first suggestion I would make without testing your code, is that you can do all the changes in your initial workbook, then SaveAs at the end... No need to close and reopen for that purpose.
When you do SaveAs, changes are only saved in the new copy.
This will require a bit of refactoring of your code (just use one wb instead of two).
Then, you can use application.screenupdating = false at start (and = false at the end), which should significantly increase the speed of processing of your script, as Excel doesn't need to draw the changes on screen.
Some other minor changes... You can set your wb immediately after you declare it, and then reuse the variable for things like :
folderPath = wb.path
Or
With wb
.....
'instead of With ActiveWorkbook
Hope this helps.
EDIT:
Added an improved version - or so i hope.
Option Explicit 'Is always advisable to use Option Explicit, it will identify any variables that haven't been declared or possible mispelling in some
Sub test()
With Application
.ScreenUpdating = False
.DisplayAlerts = False
'.Calculation = xlCalculationManual 'If you have lots of formulas in your spreadsheet, deactivating this could help as well
End With
'Uncomment the below when you are confident your code is working as intended
'On Error GoTo errHandler 'if any error, we need to reactivate the above
'Declaring the variables - i would always start with the workbook, as you can declare and initialize immediately (if known)
Dim wb As Workbook: Set wb = ActiveWorkbook
Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1")
Dim newValue As Variant: newValue = InputBox("Statement for input box")
Dim newBook As String: newBook = wb.Path & "\" & newValue & ".xlsm"
Dim i As Long, lastColumn As Long, lastRow As Long, stopColumn As Long
With wb
With ws
lastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
lastRow = .Cells(.Rows.Count, lastColumn).End(xlUp).row
stopColumn = lastColumn - 12
For i = 4 To stopColumn Step 2
If .Cells(2, i).Value <> newValue Then
.Range(.Cells(2, i), .Cells(2, i + 1)).EntireColumn.Hidden = True
End If
Next i
End With 'ws
.SaveAs Filename:=newBook, FileFormat:=xlOpenXMLWorkbookMacroEnabled
.Close SaveChanges:=True
End With 'wb
GoTo finish 'If no errors, skip the errHandler
errHandler:
MsgBox "An error occured, please step through code or comment the 'On Error GoTo errHandler"
finish:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
'.Calculation = xlCalculationAutomatic
End With
End Sub
I found this excellent code however I need to adapt it for my purposes.
Firstly I need to open a data workbook that is on our network. The problem I have is that it is likely at times to be open by another user and will offer the option of "read only". How can I get it to accept the read-only option so that I can commence extracting the data.
Secondly it copies using the "=" . How can I change it to copy just the values?
First macro:
Sub test()
'to open another workbook
Application.ScreenUpdating = False
Workbooks.Open Filename:=ThisWorkbook.Path & "\Schedule.xls"
ThisWorkbook.Activate
Application.ScreenUpdating = True
End Sub
2nd Macro:
Dim Sh As Worksheet
Dim Newsh As Worksheet
Dim myCell As Range
Dim ColNum As Integer
Dim RwNum As Long
Dim Basebook As Workbook
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Delete the sheet "Summary-Sheet" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ThisWorkbook.Worksheets("Summary-Sheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'Add a worksheet with the name "Summary-Sheet"
Set Basebook = ThisWorkbook
Set Newsh = Basebook.Worksheets.Add
Newsh.Name = "Summary-Sheet"
'The links to the first sheet will start in row 2
RwNum = 1
For Each Sh In Basebook.Worksheets
If Sh.Name <> Newsh.Name And Sh.Visible Then
ColNum = 1
RwNum = RwNum + 1
'Copy the sheet name in the A column
Newsh.Cells(RwNum, 1).Value = Sh.Name
For Each myCell In Sh.Range("A1,D5:E5,Z10") '<--Change the range
ColNum = ColNum + 1
Newsh.Cells(RwNum, ColNum).Formula = _
"='" & Sh.Name & "'!" & myCell.Address(False, False)
Next myCell
End If
Next Sh
Newsh.UsedRange.Columns.AutoFit
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
You could always open the workbook as read-only if you are only extracting data.
Instead of using .formula use .value
I've made a macro that suites my needs perfectly except for one thing. Currently it creates new workbooks for me with no format. I would like to change this so that it references a template and uses that formatting.
I've been messing with the "Set wbDest = Workbooks.Add(xlWBATWorksheet)" line, but can't seem to get anything to work!
Private Sub CommandButton1_Click()
Const sColumn As String = "M"
Dim wbDest As Workbook
Dim rngFilter As Range, rngUniques As Range
Dim cell As Range
Set rngFilter = Range(sColumn & "1", Range(sColumn & Rows.Count).End(xlUp))
Application.ScreenUpdating = False
With rngFilter
.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set rngUniques = Range(sColumn & "2", Range(sColumn & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
End With
For Each cell In rngUniques
Set wbDest = Workbooks.Add(xlWBATWorksheet)
rngFilter.AutoFilter Field:=1, Criteria1:=cell.Value
rngFilter.EntireRow.Copy
With wbDest.Sheets(1).Range("A1")
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteValuesAndNumberFormats
End With
Application.CutCopyMode = True
wbDest.Sheets(1).Name = cell.Value
Application.DisplayAlerts = False
wbDest.SaveAs ThisWorkbook.Path & Application.PathSeparator & cell.Value & " " & Format(DateSerial(Year(Date), Month(Date) - 1, 1), "mm-yy")
wbDest.Close False
Application.DisplayAlerts = True
Next cell
rngFilter.Parent.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub
`
Workbooks.Add() accepts a single argument - Template. So create a template, save it as an .xltx file, then use that filepath to add your new workbook:
Dim wb As Workbook
Dim filepath As String
filepath = "C:\template.xltx" 'Or what-ever...
Set wb = Application.Workbooks.Add(filepath)
With wb
'...
End With
how about..
Dim wbTemplate As Workbook
Set wbTemplate = Workbooks.Open("C:\mytemplate.xlsx")
Where mytemplate.xlsx is your preformatted template. The reason I assigned it to a variable object is because it looks like you'll need to reference it in order to enter data onto the template. If you simply trying to open a workbook, the one-liner below is acceptable..
Workbooks.Open("C:\mytemplate.xlsx")