I am stuck on a line and don´t know how to solve the error. I´m dividing the lines in a list by filtering different names with an advanced filter and copying the data in individual sheets, but got stuck on a line, the last one before the Next: "newWS.Range("A1").Paste". I get error 1004 from debugging:
Private Sub loopfilter()
Dim thisWB As Workbook
Dim filterws As Worksheet
Dim howto As Worksheet
Dim advfilter As Range
Dim Postenws As Worksheet
Dim VersandRange As Range
Dim rng As Range
Dim Name As String
Set thisWB = ThisWorkbook
Set filterws = thisWB.Sheets("Filtro")
Set howto = thisWB.Sheets("How to")
Set advfilter = filterws.Range("A1:AK2")
Set Postenws = thisWB.Sheets("Alle gemahnten Posten (2)")
Set VersandRange = howto.Range("J2", Cells(Rows.Count, "j").End(xlUp))
Dim newWS As Worksheet
For Each rng In VersandRange
filterws.Range("AK2") = rng.Value
Application.CutCopyMode = False
Postenws.Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=advfilter, _
CopyToRange:=filterws.Range("A5"), _
Unique:=False
filterws.Range("a5").CurrentRegion.Copy
Set newWS = thisWB.Sheets.Add
newWS.Name = rng.Value
newWS.Range("A1").Paste
Next
End Sub
Any idea why its not working?
Thanks
Try this (also made a sheet reference to your definition of Versandrange). Paste is not a method of the range object.
Private Sub loopfilter()
Dim thisWB As Workbook
Dim filterws As Worksheet
Dim howto As Worksheet
Dim advfilter As Range
Dim Postenws As Worksheet
Dim VersandRange As Range
Dim rng As Range
Dim Name As String
Set thisWB = ThisWorkbook
Set filterws = thisWB.Sheets("Filtro")
Set howto = thisWB.Sheets("How to")
Set advfilter = filterws.Range("A1:AK2")
Set Postenws = thisWB.Sheets("Alle gemahnten Posten (2)")
Set VersandRange = howto.Range("J2", howto.Cells(Rows.Count, "j").End(xlUp))
Dim newWS As Worksheet
For Each rng In VersandRange
filterws.Range("AK2").value = rng.Value
Application.CutCopyMode = False
Postenws.Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=advfilter, _
CopyToRange:=filterws.Range("A5"), _
Unique:=False
Set newWS = thisWB.Sheets.Add
newWS.Name = rng.Value
filterws.Range("a5").CurrentRegion.Copy newWS.Range("A1")
filterws.Range("a5").CurrentRegion.clearcontents
Next
End Sub
Related
I have 4 dependent drop down lists with data validation, and I'm trying to loop through the entire list and make a copy of the workbook each time.
I made a code using code from here: https://www.youtube.com/watch?v=OY5mqdcBdDk
However, my third level drop down list isn't looping and I end up getting results with the wrong matches in the hierarchy. How can I fix this?
My drop down lists are in cell C6, F6, C7, and F7.
Any help would be appreciated!
Sub myFiles()
Dim wb As Workbook
Dim ws As Worksheet
Dim DVCell1 As Range
Dim DVCell2 As Range
Dim DVCell3 As Range
Dim DVCell4 As Range
Dim DVRange1 As Range
Dim DVRange2 As Range
Dim DVRange3 As Range
Dim DVRange4 As Range
Dim DVListItem1 As Range
Dim DVListItem2 As Range
Dim DVListItem3 As Range
Dim DVListItem4 As Range
Dim Path As String
Path = "C:\MyFiles\"
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Template_view")
Set DVCell1 = ws.Range("C6")
Set DVRange1 = Evaluate(DVCell1.Validation.Formula1)
Set DVCell2 = ws.Range("F6")
Set DVRange2 = Evaluate(DVCell2.Validation.Formula1)
Set DVCell3 = ws.Range("C7")
Set DVRange3 = Evaluate(DVCell3.Validation.Formula1)
Set DVCell4 = ws.Range("F7")
Set DVRange4 = Evaluate(DVCell4.Validation.Formula1)
For Each DVListItem1 In DVRange1
DVCell1 = DVListItem1
For Each DVListItem2 In DVRange2
DVCell2 = DVListItem2
For Each DVListItem3 In DVRange3
DVCell3 = DVListItem3
For Each DVListItem4 In DVRange4
DVCell4 = DVListItem4
ws.Copy
Set nwb = ActiveWorkbook
Set nws = nwb.Worksheets("Template_view")
With nws
Cells.Copy
Cells.PasteSpecial (xlPasteFormulas)
End With
Application.DisplayAlerts = False
nwb.SaveAs Filename:=Path & DVListItem1 & DVListItem2 & DVListItem3 & DVListItem4 & ".xlsx", FileFormat:=xlWorkbookDefault
nwb.Close
Application.DisplayAlerts = True
Next DVListItem4
Next DVListItem3
Next DVListItem2
Next DVListItem1
End Sub
In one file I have data (Zeszyt.xlsm - Sheet1) and in the other an empty file (Sheet2) with the same headers and fill in button. However, when I press the button. There is no mistake but nothing complements. Could you help me ?
Private Sub CommandButton2_Click()
Dim wb As Workbook
ThisWorkbook.Worksheets("Sheet1").Rows(12).Copy
Selection.Copy
Set wb = Workbooks.Open("C:\Users\admin\Desktop\TEST\Zeszyt2.xlsm")
wb.Worksheets("Sheet2").Activate
lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
ActiveSheet.Cells(lastrow + 1, 1).Select
ActiveSheet.Paste
ActiveWorkbook.Save
ActiveWorkbook.Close savehanges = True
Set wb = Nothing
ThisWorkbook.Worksheets("Sheet1").Activate
ThisWorkbook.Worksheets("Sheet1").Cells(1, 1).Select
Application.CutCopyMode = False
End Sub
There is no need to select or copy/paste.
First of all I would propose to put all parameters like workbook names etc. as constants to the header of the module. By that it is much easier to fix renamings etc.
By having a generic copyRangeValues-routine you can re-use this sub for other copy-actions as well:
Option Explicit
'config source
Private Const wsSourceName As String = "Sheet1"
Private Const rowToCopy As Long = 12 'is this really always row 12????
Private Const wbTargetName As String = "C:\Users\admin\Desktop\TEST\Zeszyt2.xlsm"
Private Const wsTargetName As String = "Sheet2"
Private Sub CommandButton2_Click()
'First step: prepare your source range
Dim wbSource As Workbook
Set wbSource = ThisWorkbook
Dim wsSource As Worksheet
Set wsSource = wbSource.Worksheets(wsSourceName)
Dim rgSource As Range
Set rgSource = wsSource.Rows(rowToCopy)
'second step: prepare your top left target cell
Dim wbTarget As Workbook
Set wbTarget = Workbooks.Open(wbTargetName)
Dim wsTarget As Worksheet
Set wsTarget = wbTarget.Worksheets(wsTargetName)
Dim lastRow As Long
lastRow = wsTarget.UsedRange.Rows.Count
Dim rgTargetCell As Range
Set rgTargetCell = wsTarget.Cells(lastRow + 1, 1)
'third step: copy range - use generic routine
copyRangeValues rgSource, rgTargetCell
'fourth step: close target workbook
wbTarget.Close saveChanges:=True
End Sub
'Put this in a general module
Public Sub copyRangeValues(rgSource As Range, rgTargetCell As Range)
'generic routine to copy one range to another
'rgTargetCell = top left corner of target range
Dim rgTarget As Range
'resize rgTarget according to dimensions of rgSource
With rgSource
Set rgTarget = rgTargetCell.Resize(.Rows.Count, .Columns.Count)
End With
'write values from rgSource to rgTarget - no copy/paste necessary!!!
'formats are not copied - only values
rgTarget.Value = rgSource.Value
End Sub
Copy Row To Another File
The code will run slower if you use Activate and Select. but not if you use variables.
Option Explicit
Private Sub CommandButton2_Click()
Const swsName As String = "Sheet1"
Const sRow As Long = 12
Const dFilePath As String _
= "C:\Users\admin\Desktop\TEST\Zeszyt2.xlsm"
Const dwsName As String = "Sheet2"
Dim swb As Workbook: Set swb = ThisWorkbook
Dim sws As Worksheet: Set sws = swb.Worksheets(swsName)
Dim srg As Range: Set srg = sws.Rows(sRow)
Application.ScreenUpdating = False
Dim dwb As Workbook: Set dwb = Workbooks.Open(dFilePath)
Dim dws As Worksheet: Set dws = dwb.Worksheets(dwsName)
Dim dCell As Range
Set dCell = dws.Cells(dws.Rows.Count, "A").End(xlUp).Offset(1)
srg.Copy Destination:=dCell
dwb.Close SaveChanges:=True
Application.ScreenUpdating = True
MsgBox "Done.", vbInformation, "Append Row"
End Sub
I am Trying to run this Code, which will copy the Source sheet Row to Destination Sheet last Row, but my this code giving error 400 while compiling,
Advance Thanks for Help
Sub CopyData()
Dim sBook_t As String
Dim sBook_s As String
Dim sSheet_t As String
Dim sSheet_s As String
On Error GoTo Errorcatch
sBook_t = "C:\Users\Unknown\Desktop\Free\Calculators.xlsx"
Workbooks.Open (sBook_t)
sBook_s = "C:\Users\Unknown\Desktop\Free\PRODUCT_35.xlsm"
Workbooks.Open (sBook_s)
sSheet_t = "cstdatalist"
sSheet_s = "cstdata"
Sheets(sSheet_s).Range("A2").Copy Destination:=Sheets(sSheet_t).Range("A2")
End Sub
Have a try on following sub.
Sub CopyData()
Dim wb As Workbook
Dim sht, shtLocal As Worksheet
Dim rngPaste As Range
Dim rngLastData, wbPath As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
wbPath = "D:\dBook.xlsx"
Set wb = Workbooks.Open(wbPath)
Set sht = wb.Sheets(1)
Set shtLocal = ThisWorkbook.Sheets("Sheet1")
Set rngPaste = sht.Cells(Rows.Count, 1).End(xlUp).Offset(1) 'Destination range set after last used cell of column A
rngLastData = shtLocal.Cells(Rows.Count, "A").End(xlUp).Address
shtLocal.Range("A1:" & rngLastData).Copy rngPaste
wb.Save
wb.Close
Set sht = Nothing
Set shtLocal = Nothing
Set rngPaste = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
enter code hereHere is my adjustment of your code. What I did is declared the workbooks and the worksheets separately. This way it is clear which workbook/sheet is the source and which is the destination.
Sub CopyData()
Dim sBook_t As String
Dim sBook_s As String
Dim workbook_t As Workbook
Dim sSheet_t As Worksheet
Dim sSheet_s As Worksheet
Dim sSheet_t As String
Dim sSheet_s As String
On Error GoTo Errorcatch
sBook_t = "C:\Users\Unknown\Desktop\Free\Calculators.xlsx"
set workbook_t = Workbooks.Open (sBook_t)
sBook_s = "C:\Users\Unknown\Desktop\Free\PRODUCT_35.xlsm"
set workbook_s = Workbooks.Open (sBook_s)
set sSheet_t = workbook_t.Sheets("cstdatalist")
set sSheet_s = workbook_s.Sheets("cstdata")
sSheet_s.Range("A2").Copy Destination:=sSheet_t.Range("A2")
End Sub
I want to copy the value from current sheet to another workbooks with auto filter by creating new one, once I run the code I got the error:
Object variable or with block variable not set
Here's the code:
Sub copyvaluetoanothersheet()
Dim selectrange As Range
Dim wb As Workbook
Dim Dsheet As Worksheet
Dim Lastrow As Long
Application.ScreenUpdating = False
Set wb = Workbooks.Add
Set Dsheet = wb.Worksheets(1)
Lastrow = Sheet2.Range("A" & Rows.Count).End(xlUp).Row
selectrange = Sheet2.Range("A2:BP" & Lastrow)
With Worksheets("Production data")
.AutoFilterMode = False
selectrange.AutoFilter field:="Branch", Criteria1:="Direct Response"
selectrange.SpecialCells(xlCellTypeVisible).EntireRow.Copy
End With
Dsheet.PasteSpecial xlPasteValues
Application.ScreenUpdating = True
End Sub
Many thanks
You must use Set when assigning object variables (you've done it elsewhere).
Set selectrange = Sheet2.Range("A2:BP" & Lastrow)
Note too that your mixture of sheet code names, tab names, and indexes is confusing, and that your code will error if nothing is visible.
Try following
Sub cpVisible()
Dim MyProdName As String
Dim FilteredRange As Range
Dim myArr As Variant
Sheets("Production Data").Range("$A$2:$BP$50000").AutoFilter Field:="Branch", Criteria1:="Direct Response"
Set FilteredRange = Sheets("Production Data").Range("$A$2:$BP$50000").SpecialCells(xlCellTypeVisible)
FilteredRange.Copy Sheets("Dsheet").Range("A1")
End Sub
I am trying to create a VBA script that will gather data from four different Workbooks. For now, I am just testing the code with one Workbook, but I am receiving an error when I try to acquire the data. While I would like to retrieve the data from the four Workbooks without opening them, I will need to open them in order to find the last row of data. Here is my current code:
Public Sub GetData()
Application.ScreenUpdating = False
Dim LastRow As Integer
Dim WB As Workbook
Dim xlsPath As String
Dim xlsFilename As String
Dim SheetName As String
xlsPath = "C:\Users\a27qewt\My Documents\Document Retention\FI_DocumentRetention.xlsm"
Set WB = Workbooks.Open(xlsPath)
'Workbooks("FI_DocumentRetention.xlsm").Sheets("S&S Document Locations").Unprotect
LastRow = Workbooks("FI_DocumentRetention.xlsm").Sheets("S&S Document Locations").Cells(Rows.Count, "A").End(xlUp).Row
Workbooks("SS_Index.xlsm").Sheets("Document Index").Range(Cells(2, 1), Cells(LastRow, 5)).Value = _
Workbooks("FI_DocumentRetention.xlsm").Sheets("S&S Document Locations").Range(Cells(2, 1), Cells(LastRow, 5)).Value
WB.Close False
End Sub
I am receiving a 1004 application/object defined error in the Workbooks("FI_DocumentRetention.xlsm").Sheets("S&S Document Locations").Range... line. Any suggestions why?
You already solved your problem, but here's how I'd approach it
Public Sub GetData()
Dim LastRow As Long '<< not Integer
Dim WB As Workbook
Dim xlsPath As String
Dim xlsFilename As String
Dim SheetName As String
Dim shtSrc As Worksheet, shtDest As Worksheet, rngSrc As Range
Application.ScreenUpdating = False
xlsPath = "C:\Users\a27qewt\My Documents\Document Retention\FI_DocumentRetention.xlsm"
Set WB = Workbooks.Open(xlsPath)
Set shtSrc = WB.Sheets("S&S Document Locations")
Set shtDest = Workbooks("SS_Index.xlsm").Sheets("Document Index")
LastRow = shtSrc.Cells(shtSrc.Rows.Count, "A").End(xlUp).Row
Set rngSrc = shtSrc.Range(shtSrc.Range("A2"), _
shtSrc.Cells(LastRow, 5))
shtDest.Range("A2").Resize(rngSrc.Rows.Count, _
rngSrc.Columns.Count).Value = rngSrc.Value
WB.Close False
End Sub