I have a Pivot table whose row number could change depending on the data. I want to copy the pivot table and paste it as values starting from column B in another existing sheet.
To do this, i first tried getting the name of the pivot and stored it in a named range using the following code:
Sub ListPivotsInfor()
Dim St As Worksheet
Dim NewSt As Worksheet
Dim pt As PivotTable
Dim I, K As Long
Application.ScreenUpdating = False
Set NewSt = Worksheets.Add
ActiveSheet.Name = "ListOfPivotTables"
I = 1: K = 2
With NewSt
.Cells(I, 1) = "Name"
.Cells(I, 2) = "Sheet"
.Cells(I, 3) = "Location"
For Each St In ActiveWorkbook.Worksheets
For Each pt In St.PivotTables
I = I + 1
.Cells(I, 1).Value = pt.Name
.Cells(I, 2).Value = St.Name
.Cells(I, 3).Value = pt.TableRange1.Address
Next
Next
.Activate
End With
Application.ScreenUpdating = True
Dim cell As Range
Dim rng As Range
Dim RangeName As String
Dim CellName As String
'Single Cell Reference (Workbook Scope)
RangeName = "PivotName"
CellName = "A2"
Set cell = Worksheets("ListOfPivotTables").Range(CellName)
ThisWorkbook.Names.Add Name:=RangeName, RefersTo:=cell
I later tried to copy the pivot table and paste it in another sheet using the following code:
Worksheets.Add
ActiveSheet.Name = "GEP"
Worksheets("GEP Write").PivotTables(PivotName).TableRange2.Copy Destination:=Worksheets("GEP").Range("B1")
The last line is throwing a "Run time error 1004: Unable to get the PivtoTables property of the worksheet class".
Appreciate any help.
Regards
Related
This should be simple but I cannot get the examples online to solve my error.
Thanks for your help.
Regards Peter
I have 2 sheets: BOQ and OrderCodes
I am looping through rows in BOQ column"B" and when i find a value I lookup a Named Range in OrderCodes sheet
The Range is called "Lookup_CostCodes"
An example of the Vlookup i require is
Vlookup(1002,LookupCostCodes,3,false)
The relevant code is as follows:
Dim SourceSheet As Worksheet
Dim OrderCodesWs As Worksheet
Dim CostCodesRng As Range
Set OrderCodesWs = ThisWorkbook.Worksheets("OrderCodes")
Set CostCodesRng = OrderCodesWs.Range("Lookup_CostCodes")
On Error GoTo failure
Set sourceSheet = ActiveWorkbook.Sheets("BOQ")
outputRow = START_ROW
Dim sheet As Worksheet
For i = 1 To Range("_7000").row
If Val(sourceSheet.Cells(i, 11).Value) <> 0 And sourceSheet.Cells(i, 11).HasFormula Then
orderRef = sourceSheet.Cells(i, 2)
costCodeValue = Val(sourceSheet.Cells(i, 1))
costCode = Application.WorksheetFunction.VLookup(costCodeValue, "CostCodes!" & CostCodesRng.Address, 3, False)
End If
Next i
On Error GoTo 0
I have wrote the following snippet to address your problem. If this is what you wanted then please do integrate it in your main code.
Public Worksheet As Worksheet
Set Worksheet = Worksheets("BOQ")
Range("B2:B" & lr).Select
For Each cell In Selection
If cell.Value <> "" Then
cell.Offset(columnOffset:=1).Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-1],Lookup_CostCodes!C[-1]:C[0],2,FALSE)"
Range("B2").Select
End If
Next
Im trying to copy and paste my data and assign them into different worksheets.For example, if column F is martin 1, the entire row that has martin1 will be paste to worksheets("Index1"). Same thing for Charlie 1 and it will be paste to worksheets("Index2"). However, I faced with a object defined error here as shown in my code below. Any ideas how to solve it?
Sub SaveRangewithConsecutiveDuplicateValuestoNewSheet()
'Define all variables
Dim wb As Workbook, ws As Worksheet, sCel As Range, rwNbr As Long
Set wb = ThisWorkbook 'Set workbook variable
Set ws = wb.Worksheets("Sheet1") 'set worksheet variable using workbook variable
Set sCel = ws.Cells(1, 6) 'Set the first start cell variable to test for duplicate values
Dim i As Integer
Dim site_i As Worksheet
For i = 1 To 3
Set site_i = Sheets.Add(after:=Sheets(Worksheets.count))
site_i.Name = "Index" & CStr(i)
Next i
Application.DisplayAlerts = False
For rwNbr = 2 To ws.Cells(ws.Rows.count, 6).End(xlUp).Offset(1).Row Step 1 'Loop
If ws.Cells(rwNbr, 6).Value = "Martin1" Then
ws.Range(sCel, ws.Cells(rwNbr, 6)).EntireRow.Copy Destination:=Sheets("Index1").Range("A1")
ElseIf ws.Cells(rwNbr, 6).Value = "Charlie1" Then
ws.Range(sCel, ws.Cells(rwNbr - ws.UsedRange.Rows.count, 6)).EntireRow.CopyDestination:=Sheets("Index2").Range("A1") '<----application defined or object defined error here
End If
Next rwNbr
Application.DisplayAlerts = True
End Sub
This is the link to my worksheet. https://www.dropbox.com/home?preview=Sample+-+Copy.xlsm
The final output should look something like this...
If your raw data does not have a header row then I would use a loop to gather up your target cells and copy them accordingly.
You will need to update your 3 target values inside Arr to Charlie1, Martin1, etc.
Macro Steps
Loop through each name in Arr
Loop through each row in Sheet1
Add target row to a Union (collection of cells)
Copy the Union to the target sheet where target Sheet Index # = Arr position + 1
Sub Filt()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim cs As Worksheet
Dim Arr: Arr = Array("Value1", "Value2", "Value3")
Dim x As Long, Target As Long, i As Long
Dim CopyMe As Range
'Create 3 Sheets, move them to the end, rename
For x = 1 To 3
Set cs = ThisWorkbook.Sheets.Add(After:=Sheets(ThisWorkbook.Sheets.Count))
cs.Name = "Index" & x
Next x
lr = ws.Range("F" & ws.Rows.Count).End(xlUp).Row
'Loop through each name in array
For Target = LBound(Arr) To UBound(Arr)
'Loop through each row
For i = 1 To lr
'Create Union of target rows
If ws.Range("F" & i) = Arr(Target) Then
If Not CopyMe Is Nothing Then
Set CopyMe = Union(CopyMe, ws.Range("F" & i))
Else
Set CopyMe = ws.Range("F" & i)
End If
End If
Next i
'Copy the Union to Target Sheet
If Not CopyMe Is Nothing Then
CopyMe.EntireRow.Copy Destination:=ThisWorkbook.Sheets("Index" & Target + 1).Range("A1")
Set CopyMe = Nothing
End If
Next Target
End Sub
Tested and working as expected on my end, however....
If you had headers this would be much easier with a copy/paste. If you run the same macro on same book twice this will break for many reasons such as having duplicated sheet names, breaking the relationship between Sheet Index # = Arr Position + 1, etc...
I want to delete entire row if value in column B (sheet "Track") is the same as value in column B (sheet "Active").
But run time error 13 (type mismatch) always occur even though both values I refer are string type
Here is the code:
Sub delete_row()
Dim active As Worksheet: Set activeSH = ThisWorkbook.Sheets("Active")
Dim Tracksheet As Worksheet: Set KPI = ThisWorkbook.Sheets("Track")
Dim i As Integer
Dim name As String
With Tracksheet
For i = .Cells(.Rows.Count, 1).End(xlUp).Row To 4 Step -1
name = .Range("B" & i).Value
'Here I loop through each value in col B of Track sheet
'and reference it to values in col B of sheet "active"
If name = active.Range("B:B").Value Then 'this line where run time error 13 (type mismatch occurs)
.Rows(i).EntireRow.Delete
Else
End If
i = i - 1
Next i
End With
End Sub
I really appreciate your help!
You might wanna try something like this:
Sub delete_row()
Dim active As Worksheet
Dim Tracksheet As Worksheet
Dim i As Integer
Dim name As String
Dim cl As Range
Set active = ThisWorkbook.Sheets("Active")
Set Tracksheet = ThisWorkbook.Sheets("Track")
With Tracksheet
For i = .Cells(.Rows.Count, 1).End(xlUp).Row To 4 Step -1
name = .Range("B" & i).Value
For Each cl In active.Range("B1:B100")
If name = cl.Value Then
.Rows(i).EntireRow.Delete
End If
Next cl
i = i - 1
Next i
End With
End Sub
You can change the Range B1:B100 as per your requirement.
I have a worksheet (Sheet2) where there are pasted rows at Columns B:D at different row numbers.
These row numbers actually correspond with the row numbers in worksheet (Sheet1) which are blank and I wish to paste the cells dynamically into Columns C:E.
I have the following code which allows me to copy the row from Columns B:D based on a text value = "LAW" and paste in Sheet1 as long as I know the range of the cell in Column C.
I suppose what I am looking for is the equivalent of when "LAW" is found, match the row with the one in Sheet1 and paste at Column C. A loop is necessary as there are other instances where "LAW" is found and these cells need to be pasted at the appropriate cell range.
Dim WBT As Workbook
Dim WSD1 As Worksheet
Dim WSD2 As Worksheet
Set WBT = Workbooks("Invoices.csv")
Set WSD1 = WBT.Worksheets("Sheet1")
Set WSD2 = WBT.Worksheets("Sheet2")
Set r2 = WSD1.Range("C11")
With WSD2
N = .Cells(Rows.Count, "B").End(xlUp).row
For i = 1 To N
If .Cells(i, "B").Value = "LAW" Then
Set r1 = Range(.Cells(i, "B"), .Cells(N, "D"))
r1.Copy r2
End If
Next i
End With
I found it rather difficult to come up with a failsafe solution however, I hope someone can give me a few pointers as how I should go about this.
The example below demonstrates that I want to look for the rows in Sheet2 and paste them at the highlighted points in Sheet1. If there is a way of dynamically saying If Text in Column B on Sheet2 = LAW then copy that row (from Columns B to D) to the equivalent row in Sheet1. In my example I have two instances where this occurs.
Following the success of the amendment to the script by #SJR I then struck a problem where the Workbook had many many sheets. So I modified the code and used a function to test if a sheet exists (default is Not)
Function SheetExists(shtName As String, Optional wb As Workbook) As Boolean
Dim sht As Worksheet
If wb Is Nothing Then Set wb = ThisWorkbook
On Error Resume Next
Set sht = wb.Sheets(sht)
On Error Resume Next
SheetExists = Not sht Is Nothing
End Function
and duplicated the code as follows:
Dim r1 As Range
Dim r2 As Range
Dim N As Long
Set r2 = WSD1.Range("C1:C100")
With WSD2
If Not SheetExists("Sheet1") Then
N = .Cells(Rows.Count, "B").End(xlUp).row
For i = 1 To N
If .Cells(i, "B").Value = "LAW" Then
Set r1 = Range(.Cells(i, "B"), .Cells(i, "D"))
r1.Copy WSD1.Cells(i, "C")
End If
Next i
Else
On Error Resume Next
End If
End With
With WSD3
If Not SheetExists("Sheet2") Then
N = .Cells(Rows.Count, "B").End(xlUp).row
For i = 1 To N
If .Cells(i, "B").Value = "LAW" Then
Set r1 = Range(.Cells(i, "B"), .Cells(i, "D"))
r1.Copy WSD1.Cells(i, "C")
End If
Next i
Else
On Error Resume Next
End If
End With
Although this works fine where the workbook has 2 sheets it falls over on the second script referencing WSD3 at N = .Cells(Rows.Count, "B").End(xlUp).rowwith run time error '91'. By stepping through the code I find that the variable for R1 comes up with the message if you hover over the Range???? Although I tried to figure out why it is saying the variable is not set I am confused.
Can you try this? Think you had an errant N in the line assigning r1.
Sub x()
Dim WBT As Workbook
Dim WSD1 As Worksheet
Dim WSD2 As Worksheet, N As Long
Set WBT = Workbooks("Invoices.csv")
Set WSD1 = WBT.Worksheets("Sheet1")
Set WSD2 = WBT.Worksheets("Sheet2")
Set r2 = WSD1.Range("C11")
With WSD2
N = .Cells(Rows.Count, "B").End(xlUp).Row
For i = 1 To N
If .Cells(i, "B").Value = "LAW" Then
Set r1 = .Range(.Cells(i, "B"), .Cells(i, "D"))
r1.Copy WSD1.Cells(i, "C")
End If
Next i
End With
End Sub
My workbook has two sheets: one "Data" and one "Kiert". I solved to copy rows by specific attributes from "data" to "Kiert" with UserForm, but I added ti user form four textboxes (TextBox1, TextBox2 etc.) and I want to fill the database with constant values added in textbox with one command button in blank colums after pasted data.
I have additional textbox5, which indicates if the copy was succefull ("SIKERES"), this part works fine...
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim Drng As Range, c As Range
Dim i As Long
Dim lastRow As Long
Dim srcRange As Range, fillRange As Range
Set a = TextBox5
Set d = TextBox1
Set ws = Sheets("Data")
Set Drng = ws.Columns("A:A").SpecialCells(xlCellTypeConstants, 23)
For Each c In Drng.Cells
If c = ListBox1 Then
c.EntireRow.Copy
Sheets("Kiert").Range("A1000000").End(xlUp).Offset(1, 0)
Range("F:F" & lastRow).Formula = TextBox1.Value
If c.Value = ListBox1.Value Then
a.Value = "SIKERES"
End If
End If
Next c
End Sub
I insert here an example:
My main problem is I cannot describe a correct range and description of textboxes, and I don't know where I can put it in my code to run it properly.
I tried this:
For Each c In Drng.Cells
If c = ListBox1 Then
c.EntireRow.Copy Sheets("Summary").Range("A1048576").End(xlUp).Offset(1, 0)
Sheets("Kiert").Range("A:A" & lasrRow).Value = TextBox1.Text
If c.Value = ListBox1.Value Then
A.Value = "SIKERES"
End If
End If
Next c
...but its out of range.
It's not very clear what you are trying to do, but the code below will help you paste the values of your textboxes to the relevant column:
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim Drng As Range, c As Range
Dim i As Long
Dim NextFreeRow As Long
Dim srcRange As Range, fillRange As Range
Set Drng = Sheets("Data").Columns("A:A").SpecialCells(xlCellTypeConstants, 23)
For Each c In Drng.Cells 'loop through Column A on Sheet Data
If c = ListBox1.Value Then 'If the cells in Column A Sheet Data matches the selection on your Listbox1 then
NextFreeRow = Sheets("Kiert").Cells(Rows.Count, "A").End(xlUp).Row + 1 'Check the next free row on Sheet Kiert
c.EntireRow.Copy Desination:=Sheets("Kiert").Range("A" & NextFreeRow) 'Paste the entire row from Sheet Data to Sheet Kiert
Range("F" & NextFreeRow).Value = TextBox1.Text 'Copy the contents of TextBox1 to column F
'Add more lines like the one above to copy the values from your Textboxes to the relevant column
TextBox5.Text = "SIKERES"
End If
Next c
End Sub