This code is supposed to transfer pivot table data from one workbook to other, works fine for a few loops, however, the row increment which is being tried isn't catching up after a few loops. I'm not sure why it messes up after running a few loops!
Sub copypivotdata()
Dim x As Workbook
Dim y As Workbook
Dim n As String, ws As Worksheet
Dim pvt As Range
Dim i, i2 As Integer
Set x = Workbooks("WorkbookA.xlsm")
Set y = Workbooks("WorkbookB.xlsm")
i = 2
'Now, transfer values from x to y:
x.Activate
For Each ws In ActiveWorkbook.Worksheets
'With ActiveWorkbook.ActiveSheet
If ws.Name <> "Main Sheet" And ws.ChartObjects().Count <> 0 Then
ws.Activate
Else:
GoTo nextws
End If
ws.Activate
Range("A1048576").Select
Selection.End(xlUp).Select
Range(Selection, Selection.End(xlUp)).Select
Range(Selection, Selection.End(xlToRight)).Select
Set pvt = Selection
i2 = Selection.Rows.Count
'MsgBox i2
y.Activate 'activate other workbook
'With
y.Sheets("Pivot data").Range("C" & i, "D" & i2 + i) = pvt.Value
i = i2 + 2
i2 = 0
nextws: Next ws
y.Activate
End Sub
The loop logic was incorrect.. Just realized.
"i = i2 + 2" is incorrect. Should be i = i + i2
Related
I have written this code, and it works when doing it from one sheet to another. (Same workbook). But when i loop through the rows from workbook to workbook i get "Run time error 9" Subscript out of range.
I've checked several times if the filenames are as stated in the code, and it doesn't seem to be the problem. Also if I in the first piece write y.sheets("Tavledisplay") instead of worksheets("Tavledisplay") the debugger tells me there's a problem there. Doing it the latter way, it sends 1 loop of data, and stops at y.sheets("Tavledisplay").Activate.
My code:
Dim x As Workbook
Dim y As Workbook
Set x = Workbooks.Open("C:\Users\u054939\Desktop\Diverse filer\Safecard\Safecardmaster.xlsm")
Set y = Workbooks.Open("C:\Users\u054939\Desktop\Diverse filer\Safecard\Tavleark1.xlsm")
a = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To a
If Worksheets("Tavledisplay").Cells(i, 14).Value = "Ja" Then
Worksheets("Tavledisplay").Rows(i).Select
Selection.Copy
x.Sheets("Løsninger").Activate
b = Worksheets("Løsninger").Cells(Rows.Count, 1).End(xlUp).Row
x.Sheets("Løsninger").Cells(b + 1, 1).Select
ActiveSheet.Paste
y.Sheets("Tavledisplay").Activate
Selection.ClearContents
End If
Next i
Application.CutCopyMode = False
x.Sheets("Løsninger").Select
I expect the code to loop through all the given rows, where there is a "Ja" in column 14, and pasting them into my other workbook sheet "Løsninger" and deleting them from the other workbook.
You don't need to loop through each loop, a simple filter will do the trick:
Option Explicit
Sub Test()
Dim x As Workbook
Dim y As Workbook
Dim CopyRange As Range
Dim LastRow As Long
Set x = Workbooks.Open("C:\Users\u054939\Desktop\Diverse filer\Safecard\Safecardmaster.xlsm")
Set y = Workbooks.Open("C:\Users\u054939\Desktop\Diverse filer\Safecard\Tavleark1.xlsm")
'Look for the range to copy and set it
With y.Worksheets("Tabledisplay")
.UsedRange.AutoFilter Field:=14, Criteria1:="Ja"
LastRow = .Cells(.Rows.Count, 14).End(xlUp).Row
Set CopyRange = .Range("A2", .Cells(LastRow, .UsedRange.Columns.Count)).SpecialCells(xlCellTypeVisible)
.AutoFilterMode = False
End With
'Paste it to the other sheet
With x.Worksheets("Løsninger")
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
CopyRange.Copy .Cells(LastRow, 1)
End With
'Delete the range from the original sheet
CopyRange.Delete
End Sub
I have data in sheet1 (master sheet) to be divided by 300 and then pasted in every sheet.
These sheets are created by a VBA code for loop.
If my lastrow gives a decimal value I found problems.
e.g. I calculate the Last Row of MYdata and divide it by 300 as I need data in every sheet max 300. If my lastrow data is 1342, dividing by 300 I get 4.473333333. This creates only 4 sheets. I require 5 sheets of data.
Sub test()
Dim lrow As Long, lrow1 As Double
lrow = Sheet3.Range("a65000").End(xlUp).Row
lrow1 = Sheet3.Range("a65000").End(xlUp).Row
num = lrow / 300
For x = 1 To num
Sheets.Add
ActiveSheet.Name = x
Sheet3.Activate
Sheet3.Range("a2:a301").Select
Sheet3.Range("a2:a301").Cut
Sheets(x).Select Range("a1").Select
ActiveSheet.Paste
Sheet3.Select
Selection.Delete Shift:=xlUp
Next x
End Sub
This will always round you to the next whole number
num = Round((lrow / 300) + 0.5, 1)
Some suggested updates
Option Explicit
Sub Parse ()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet3")
Dim ns As Worksheet 'New Sheet
Dim lrow As Long, x
lrow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
For x = 1 To Round((lrow / 300) + 0.5, 1)
Set ns = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ns.Name = x
ws.Range("A2:A301").Copy ns.Range("A1")
ws.Range("A2:A301").Delete Shift:=xlUp
Next x
End Sub
I'm trying to input text for example "code" into a column, using the Counta formula in two cells in my historic tab.
mystart and mystop both have Counta formulas in the cells and I want to paste the word "code" for example in all the cells between the two values, but I don't how to finish my code.
The text "code" will change thought out my code to something else
Sub MON_ImportHistory()
Sheets("Historic").Range("B2:AZ3000").ClearContents
'
If Worksheets("Help").Cells(18, 9) = "Data already present" Then
MsgBox ("Import aborted: Data for selected date already present")
Else
Dim myRange As Range
Dim NumRows As Integer
Dim myCopyrange As Range
Dim mystart As Range
Dim mystop As Range
m_import = Worksheets("Help").Cells(17, 9)
m_criteria = "=" & m_import
Workbooks.Open Filename:= _
"file on my data base"
Sheets("Historic").Select
If Application.WorksheetFunction.CountIf(Range("A:A"), m_import) > 0 Then
m_Filterrange = "$A$1:$AV$" & Trim(Str(Worksheets("Historic").Cells(1, 18) - 1))
ActiveSheet.Range(m_Filterrange).AutoFilter Field:=1, Criteria1:= _
m_criteria, Operator:=xlAnd
m_extractrange = "$A$90000:$AV$" & Trim(Str(Worksheets("Historic").Cells(1, 18) - 1))
Range(m_extractrange).Select
Selection.Copy
Windows("My File name").Activate
Sheets("Historic").Select
mystart = Worksheets("Historic").Cells(1, 19)
mystop = Worksheets("Historic").Cells(1, 20)
For x = mystart To mystop
myDestination = "B" & Trim(Str(Worksheets("Historic").Cells(1, 19)))
Range(myDestination).Select
ActiveSheet.Paste
Windows("My file name").Activate
There's a lot going on here...First, it looks like you are using CountA formulas in the worksheet to do what you should be doing in VBA. There is a lot of work around being done to make that work. You are probably getting an error on the second line because you are trying to clear the contents of a sheet that has not been opened yet. To find the number of occupied rows in a column you can use LastRow = Sheets("Historic").Cells(Rows.Count,1).End(xlUp).Row. You should try to minimize or eliminate the use of Select and Activate. If you try to clean that up it may make more sense to you and me. Don't forget to end the loop with Next x.
Sub MON_ImportHistory()
Dim LastRow, LastCol As Integer
Dim ws1, ws2 As Worksheet
Dim m_import As String
Dim x As Integer
Set ws1 = Worksheets("Help")
'
If ws1.Cells(18, 9) = "Data already present" Then
MsgBox ("Import aborted: Data for selected date already present")
Exit Sub
Else
Workbooks.Open "C:\Somefile.xlsx" 'Here is where you put your filename
Set ws2 = Workbooks("Somefile.xlsx").Worksheets("Historic")
LastRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row
LastCol = ws2.Cells(1, Columns.Count).End(xlToLeft).Column
ws2.Range(ws2.Cells(2, 2), ws2.Cells(LastRow, LastCol)).ClearContents
m_import = ws1.Cells(17, 9)
For x = 2 To LastRow
ws2.Cells(x, 2) = m_import
Next x
End If
End Sub
There are a lot of threads about this error, but I can't get this to work no matter what I try. Most people say it occurs when you try to invoke a method on an inactive sheet, but you shouldn't have to do that. Error is on line 28. Thanks.
Private Sub CommandButton1_Click()
Dim x As Integer
Dim boisePaste As Integer
Dim jrgPaste As Integer
Dim master As Integer
Dim lastRow As Integer
Dim bookCount As Integer
bookCount = Application.Workbooks.Count
For x = 1 To bookCount
If Left(Application.Workbooks(x).Name, 14) = "ITEM_INVENTORY" Then
boisePaste = x
ElseIf Left(Application.Workbooks(x).Name, 6) = "report" Then
jrgPaste = x
ElseIf Left(Application.Workbooks(x).Name, 8) = "Portland" Then
master = x
End If
next x
'Unhide sheets and delete Boise range'
Application.ActiveWorkbook.Sheets("BoisePaste").Visible = True
Sheets("JRGpaste").Visible = True
lastRow = Sheets("BoisePaste").Cells(Rows.Count, "B").End(xlUp).Row
Sheets("BoisePaste").Range(Cells(1,2), Cells(lastRow, 23)).Clear
'Open Boise file and copy range, paste in master'
Application.Workbooks(boisePaste).Activate
With ActiveSheet
.Range(.Cells(1,1), .Cells((.Cells(Rows.Count, "A").End(xlUp).Row),22)).Copy
End With
Application.Workbooks(master).Sheets("BoisePaste").Range(B1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'Open JRG report and copy range, paste in master'
Application.Workbooks(jrgPaste).Activate
ActiveSheet.Cells.Copy
Application.Workbooks(master).Sheets("JRGpaste").Range(A1).Paste
Application.CutCopyMode = False
'Refresh pivot tables; hide sheets'
Application.Workbooks(master).Activate
With ActiveWorkbook
.RefreshAll
.RefreshAll
.Sheets("BoisePaste").Visible = False
.Sheets("BoisePaste").Visible = False
End With
End Sub
You need to explicitly state which sheet you want the Rows.Count and other such Range uses (Columns,Rows,Cells,etc.) will be on.
Try this:
Sheets("BoisePaste").Range(Sheets("BoisePaste").Cells(1,2), Sheets("BoisePaste").Cells(lastRow, 23)).Clear
So, go through your code and make sure you do this everywhere...i.e. in .Range(.Cells(1,1), .Cells((.Cells(Rows.Count, "A").End(xlUp).Row),22)).Copy, you didn't do it to Rows.Count, so add the sheet there too, to prevent any unexpected actions.
Think of it like this perhaps, with the line
myVariable = Sheets("mySheet").Range(Cells(1,1),Cells(1,2)).Value
VBA is reading that as
In mySheet, look for a range. What range? Hm, the user says Cells(1,1) and Cells(1,2), but what sheet does he want that? The current activesheet is called yourSheet...He specified where the Range should be (sheet called mySheet), but he didn't on Cells(), so I don't know what he wants! mySheet cells(1,1) or yourSheet cells(1,1) ??
(and yes, that's exactly how a computer thinks :P)
Edit: I went through and tried to help tighten up your code. But, as you can see perhaps, I'm not quite positive as to what you want to do, but this should give you some help/insight:
Private Sub CommandButton1_Click()
Dim x As Integer
Dim boisePaste As Integer
Dim jrgPaste As Integer
Dim master As Integer
Dim lastRow As Integer
Dim bookCount As Integer
bookCount = Application.Workbooks.Count
' Create variables to hold the workbook and sheet names.
Dim jrgWS As Worksheet, boiseWS As Worksheet
Dim masterWB As Workbook
Set masterWB = Workbooks(master)
Set jrgWS = Sheets("JRGPaste")
Set boiseWS = Sheets("BoisePaste")
For x = 1 To bookCount
If Left(Application.Workbooks(x).Name, 14) = "ITEM_INVENTORY" Then
boisePaste = x
ElseIf Left(Application.Workbooks(x).Name, 6) = "report" Then
jrgPaste = x
ElseIf Left(Application.Workbooks(x).Name, 8) = "Portland" Then
master = x
End If
Next x
'Unhide sheets and delete Boise range'
Application.ActiveWorkbook.Sheets("BoisePaste").Visible = True
jrgWS.Visible = True
With boiseWS
lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
.Range(.Cells(1, 2), .Cells(lastRow, 23)).Clear
End With
'Open Boise file and copy range, paste in master'
'' DONT USE ACTIVE SHEET! Use your variables instead
'Application.Workbooks(boisePaste).Activate
With boiseWS
'Since you want values (xlPasteValues), just set the two ranges equal instead of copy/paste
.Range("B1").Value = .Range(.Cells(1, 1), .Cells((.Cells(.Rows.Count, "A").End(xlUp).Row), 22)).Value
End With
'Open JRG report and copy range, paste in master'
' The below just pastes into the same sheet, no??
jrgWS.Cells.Copy
jrgWS.Range("A1").Paste
Application.CutCopyMode = False
'Refresh pivot tables; hide sheets'
Application.Workbooks(master).Activate
With ActiveWorkbook
.RefreshAll
.RefreshAll
.Sheets("BoisePaste").Visible = False
End With
End Sub
Its a simple code to go to a sheet pull a row, go back to the first one sheet and paste it, then repeat until the value in column A of the inventory changes (New employee) at which point it needs to make a new worksheet to start storing the new data. And repeat until its done.
Dim i As Integer
Dim j As Integer
Set i = 2
Set j = 1
Do While i < 6
Sheets("Inventory").Select
If Cells("i,1").Value = Cells("i-1,1").Value Then
Cells("i:i").Select
Selection.Copy
Sheets("Sheetj").Select
Cells("i,1").Select
Selection.Paste
i = i + 1
Else
Sheets.Add After:=Sheets(Sheets.Count)
j = j + 1
Sheets("Inventory").Select
Cells("i:i").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheetj").Select
Range("A3").Select
ActiveSheet.Paste
i = i + 1
End If
End Sub
Add this:
Loop
Before you end the sub. The i's also shouldn't have double quote if you're referencing what the number I should be. Should be like Cells(i , 1), or Cells(i , i), I'll leave you up to fix the rest.
Sorry, misread your original post. fixed.
I would do something like this to add create new sheets for each data group.
Updated: reduced my code now your "sheetj" part is clear
code
Sub Other()
Dim rng1 As Range
Dim rng2 As Range
Dim ws As Worksheet
Set rng1 = Sheets("Inventory").Range("I2:i6")
Set ws = Sheets.Add
For Each rng2 In rng1
If rng2 <> rng2.Offset(-1, 0) Then Set ws = Sheets.Add
rng2.EntireRow.Copy ws.Rows(rng2.Row)
Next
End Sub
Sub test()
Dim i As Integer
Dim j As Integer
i = 2 ' got rid of set
j = 1 ' got rid of set
Do While i < 6
Sheets("Inventory").Select
If Cells("i,1").Value = Cells("i-1,1").Value Then
Cells("i:i").Select
Selection.Copy
Sheets("Sheetj").Select
Cells("i,1").Select
Selection.Paste
i = i + 1
Else
Sheets.Add After:=Sheets(Sheets.Count)
j = j + 1
Sheets("Inventory").Select
Cells("i:i").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheets" & j).Select ' for completeness...
Range("A3").Select
ActiveSheet.Paste
i = i + 1
End If
Loop ' missing this
End Sub
Untested, but i think you use too many selects (tried with .activate ?)
Dim i As long 'long is faster for loops
Dim j As long
i = 2 'dont need set
j = 1
Do While i < 6
with Sheets("Inventory")
If .Cells(i,1).Value = .Cells(i-1,1).Value Then 'i removed the quotes in cells
.range("i:i").Copy Sheets("Sheetj").Cells(i,1)
i = i + 1
Else
Sheets.Add After:=Sheets(Sheets.Count)
j = j + 1
.Cells("i:i").copy Sheets("Sheetj").Range("A3")
i = i + 1
End If
end with
Application.CutCopyMode = False
loop 'you forgot a ending loop