I have a multidimensional power pivot table in sheet "Template2" created by a data model. I want VBA which circles through the slicer "Slicer_Sublot_code" and for each selection a new sheet to be created named after the slicer's selected item and the filtered pivot table to be pasted in it maintaining only values and format.
So far I have managed to create the empty sheets named by the slicer's items (the VBA reads the names from a range F2:F10 instead of taking them from the slicer which would be ideal):
Sub AddSheets()
Dim xRg As Excel.Range
Dim wSh As Excel.Worksheet
Dim wBk As Excel.Workbook
Set wSh = ActiveSheet
Set wBk = ActiveWorkbook
Application.ScreenUpdating = False
For Each xRg In wSh.Range("F2:F10")
With wBk
.Sheets.Add after:=.Sheets(.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xRg.Value
If Err.Number = 1004 Then
Debug.Print xRg.Value & " already used as a sheet name"
End If
On Error GoTo 0
End With
Next xRg
Application.ScreenUpdating = True
End Sub
I have also managed to do the copy/paste of the pivot table (keeping values and format) on a new sheet but the name is pre-defined "Report":
Sub PivotTablePasteSpecial()
Dim SourcePivottable As PivotTable
Dim DestinationRange As Range
Dim aCell As Range
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Set SourcePivottable = Worksheets("Template2").PivotTables(1)
Set DestinationRange = Worksheets("Report").Range("A1")
' Copy TableRange1
SourcePivottable.TableRange1.Copy
With DestinationRange.Offset( _
SourcePivottable.TableRange1.Row - SourcePivottable.TableRange2.Row, 0)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
End With
' Copy everything above TableRange1 cell-by-cell
For Each aCell In SourcePivottable.TableRange2.Cells
If Not Intersect(aCell, SourcePivottable.TableRange1) Is Nothing Then Exit For
aCell.Copy
With DestinationRange.Offset( _
aCell.Row - SourcePivottable.TableRange2.Row, _
aCell.Column - SourcePivottable.TableRange2.Column)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
End With
Next aCell
Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
How can I combine the 2 in order to achieve the desired outcome described in the first paragraph?
Related
Attempting a macro that will set all selected sheets to have same cells visible as in the active sheet.
Example: if top-left cell is L76 on active sheet, then running this macro will set all selected worksheets to show L76 as the top left cell.
Cobbled this code together from examples found online but not sufficiently advanced in VBA to make it work.
Sub SetAllSelectedSheetsToSameRowColCell()
Dim rngSel As Range
Dim intScrollCol As Integer
Dim intScrollRow As Long
Dim oSheet As Object
If TypeName(Sh) = "Worksheet" Then
Set oSheet = ActiveSheet
Application.EnableEvents = False 'Unsure what this line is for
Sh.Activate
With ActiveWindow
intScrollCol = .ScrollColumn
intScrollRow = .ScrollRow
Set rngSel = .RangeSelection
End With
oSheet.Activate
Application.EnableEvents = True
End If
'Loop thru rest of selected sheets and update to have same cells visible
Dim oWs As Worksheet
For Each oWs In Application.ActiveWindow.SelectedSheets
On Error Resume Next
oWs.Range(rngSel.Address).Select
.ScrollColumn = intScrollCol
.ScrollRow = intScrollRow
Next
End Sub
References:
https://excel.tips.net/T003860_Viewing_Same_Cells_on_Different_Worksheets.html
VBA Macro To Select Same Cell on all Worksheets
Try this:
Sub ResetAllSheetPerspectives()
Dim ws As Worksheet
Dim lRow As Long
Dim lCol As Long
Dim dZoom As Double
lRow = ActiveWindow.ScrollRow
lCol = ActiveWindow.ScrollColumn
dZoom = ActiveWindow.Zoom
For Each ws In Application.ActiveWindow.SelectedSheets
ws.Activate
ActiveWindow.Zoom = dZoom
Application.Goto ws.Cells(lRow, lCol), True
Next ws
End Sub
Maybe this will help. Sets the top left cell of other sheets depending on the first sheet.
Sub Macro1()
Dim r As Range, ws As Worksheet
Sheets(1).Activate
Set r = ActiveWindow.VisibleRange.Cells(1)
For Each ws In Worksheets
If ws.Index > 1 Then
ws.Activate
ActiveWindow.ScrollRow = r.Row
ActiveWindow.ScrollColumn = r.Column
End If
Next ws
End Sub
This procedure sets the same visible range as the active worksheet for all selected worksheets. It excludes any Chart sheet in the selection and adjusts the zoom of the selected sheets to ensure all worksheets have the same visible area.
Sub SelectedWorksheets_ToSameVisibleRange()
Dim ws As Worksheet
Dim oShs As Object, oSh As Object
Dim sRgAddrs As String
On Error Resume Next
Set ws = ActiveSheet
On Error GoTo 0
If ws Is Nothing Then
MsgBox "Active sheet must be a worksheet type" & String(2, vbLf) _
& String(2, vbTab) & "Process will be cancelled.", _
vbCritical, "Worksheets Common Range View"
Exit Sub
End If
With ActiveWindow
Set oShs = .SelectedSheets
sRgAddrs = .VisibleRange.Address 'Get address of Active Sheet visible range
End With
For Each oSh In oShs
If TypeName(oSh) = "Worksheet" And oSh.Name <> ws.Name Then 'Excludes any chart sheet and the active sheet
With oSh.Range(sRgAddrs)
Application.Goto .Cells, 1 'Activate Worksheet targeted visible range
ActiveWindow.Zoom = True 'Zoom Worksheet to make visible same range as the "active worksheet"
Application.Goto .Cells(1), 1 'Activate 1st cell of the visible range
End With: End If: Next
ws.Select 'Ungroups selected sheets
End Sub
I am trying to create a loop to copy data in cells in source worksheet one by one and paste in a particular cell in target worksheet. Once the cell is pasted, i need it to save a copy of the file then paste the next value in the source worksheet.The code is:
Private Sub CommandButton1_Click()
Dim wbTarget As Worksheet
Dim wbSource As Worksheet
Dim SaveLoc As String
Dim FName As String
Dim i As Long
Set wbSource = Sheets("Sheet3")
Set wbTarget = Sheets("Sheet1")
wbSource.Activate
Range("A1").Activate
Do While ActiveCell.Value <> ""
DoEvents
ActiveCell.Copy
For i = 1 To 30
wbTarget.Activate
With ActiveSheet
wbTarget.Range("E5").Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths
Selection.PasteSpecial Paste:=xlPasteValues
ThisWorkbook.Save
Application.CutCopyMode = False
End With
SaveLoc = "H:\Services\Test Output\Term_"
FName = Range("B5")
ActiveWorkbook.SaveCopyAs FileName:=SaveLoc & FName & ".xls" 'FileFormat:=xlNormal
Application.DisplayAlerts = False
Next i
wbSource.Select
ActiveCell.Offset(1, 0).Activate
Loop
Application.ScreenUpdating = True
End Sub
When I run this, I get a
run-time error 1004.
Please advise on how to resolve this.
Thank You in Advance.
Try the code below, without using Activate, ActiveCell, Select and Selection, instead use fully qualifies Ranges and Worksheet objects.
Explanation inside the code as comments (also some question about your code).
Code
Option Explicit
Private Sub CommandButton1_Click()
Dim wbTarget As Worksheet
Dim wbSource As Worksheet
Dim SaveLoc As String
Dim FName As String
Dim i As Long, lRow As Long
Set wbSource = Sheets("Sheet3")
Set wbTarget = Sheets("Sheet1")
' SaveLoc string never changes, doesn;t need to be set every time inside the loops
SaveLoc = "H:\Services\Test Output\Term_"
' you never qualifed the range with on of the worksheets (I'm guessing here it's "Sheet3"
FName = wbTarget.Range("B5").Value
Application.ScreenUpdating = False
lRow = 1
Do While wbSource.Range("A" & lRow).Value <> ""
wbSource.Range("A" & lRow).Copy
For i = 1 To 30
' 2 lines below you are pasting to cell "E5" don't you mean to increment with the row number (i variable)
wbTarget.Range("E5").PasteSpecial xlPasteValues
wbTarget.Range("E5").PasteSpecial xlPasteColumnWidths
ThisWorkbook.Save
Application.CutCopyMode = False
' have this line before trying to save a copy of this workbook
Application.DisplayAlerts = False
ThisWorkbook.SaveCopyAs Filename:=SaveLoc & FName & ".xls" 'FileFormat:=xlNormal
Application.DisplayAlerts = True
Next i
lRow = lRow + 1
Loop
Application.ScreenUpdating = True
End Sub
I am copying data from worksheet ws and am trying to paste just the values back to the original sheet, thus overwriting the original data with plain text. When I close the workbook I get an excel message telling me "There is a large amount of information on the clipboard. Do you want to be able to past this information into another program?" I will never want to do this. I don't want this message to not appear or assume the answer is "No".
Function FindPresenters(MyDate As Date, MyWS As String) As String
'MyDate is in format of 10/3/2016
'MyWS is the target worksheet to find MyDate
Dim GCell As Range
Dim xlApp As Object
Dim WB As Workbook
Dim WS As Worksheet
Dim MyLoop As Integer
Dim Found As Boolean
On Error GoTo ErrorHandler
Set xlApp = CreateObject("Excel.application") 'New Excel.Application
Application.ScreenUpdating = True
xlApp.Visible = True
Set WB = xlApp.Workbooks.Open ("Sched(Others).xlsx")
Set WS = WB.Worksheets("Oct 2016 Training Schedule")
With WS '.UsedRange
'.Cells.Select
.UsedRange.Select
.Cells.Copy
.Cells.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False 'This should suppress msg, but doesn't
.Range("B2").Select
End With
WS.Activate
Set GCell = WS.Cells.Find(MyDate)
Found = False
For MyLoop = 1 To MaxDayItems 'Find the entrees for the month
Debug.Print GCell.Offset(MyLoop, 0).Text
If Not Found And InStr(1, GCell.Offset(MyLoop, 0).Text, "C.O.") > 0 Then
'Found data
Found = True
FindPresenters = GCell.Offset(MyLoop, 0).Text
MyLoop = MaxDayItems + 1 'Terminate searching
End If
Next MyLoop
Done:
Application.DisplayAlerts = False 'Tried this to suppress the message
WB.Close True 'This is where the Clipboard error appears
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set WS = Nothing
Set WB = Nothing
xlApp.Quit
Set xlApp = Nothing
Exit Function
'Error Handling section.
ErrorHandler:
...
GoTo Done
End Function
Because the cells you are copying belong to xlApp (a separate instance of Excel.Application) you will need to make xlApp.CutCopyMode equal false.
xlApp.CutCopyMode = False
I agree with Comintern's comment "You're only pasting values - just write them directly"
It appears that you are simple replacing all the formulas on the worksheet with their values. This can be achieved by simply like this:
WS.UsedRange.Value = WS.UsedRange.Value
I want to remove all sheets in the current workbook exception the list in {A2,A3, ... } and the sheet with name Summary.
I wrote the following code
Dim MyCell As Range, MyRange As Range
Set MyRange = Sheets("Summary").Range("A2")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wbook = ActiveWorkbook
For Each xWs In wbook.Worksheets
For Each MyCell In MyRange
If xWs.Name <> MyCell.Value And xWs.Name <> "Summary" Then
xWs.Delete
End If
Next MyCell
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
but I get an run time error which I do not know what it is.
Then, I tried to run line by line: in the first loop over "xWs.Name= Summary" there is no problem first for the second sheet I get an error at
If xWs.Name <> MyCell.Value And xWs.Name <> "Summary" Then
I know that this code is not efficient at all, because if a name matches it is still running till the end of set of names. However, I did not know how I can compare tow sets in VBA in a efficient way.
One can see in the the list of names in A-column.
You need to approach it a little different, you need to loop though the Range on every Sheet, once you have a match you need to raise a flag not to delete this Sheet.
Try the code below:
Sub DeleteSelectedSheets()
Dim MyCell As Range, MyRange As Range
Dim wbook As Workbook, xWs As Worksheet
Dim DeleteSheetFlag As Boolean
Set MyRange = Sheets("Summary").Range("A2")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wbook = ActiveWorkbook
For Each xWs In wbook.Worksheets
DeleteSheetFlag = True
For Each MyCell In MyRange
Select Case xWs.Name
Case MyCell.Value, "Summary"
DeleteSheetFlag = False
Exit For
End Select
Next MyCell
If DeleteSheetFlag Then
xWs.Delete
End If
Next xWs
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I ahve an Excel work book containing a large number of sheets. Each sheet has between 1 and 12 Hyperlinks to different documents on a website. These dicuments are updated from time to time. I would like a macro that lists all the Hyperlinks in a new sheet but also lists the sheet name next to each link. I have the following that lists the Hyperlinks and the cell ref
Sub CopyHyperLinks()
Dim rCell As Range
Dim ws As Worksheet
Dim Lhyper As Long
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Hypers").Delete
On Error Goto 0
Application.DisplayAlerts = True
Sheets.Add().Name = "Hypers"
For Each ws In Worksheets
If ws.Name <> "Hypers" Then
For Lhyper = 1 To ws.UsedRange.Hyperlinks.Count
ws.Hyperlinks(Lhyper).Range.Copy
With Sheets("Hypers").Cells(Rows.Count, 1).End(x1Up)
.Offset(1, 0).PasteSpecial
.Offset(1, 1) = ws.Hyperlinks(Lhyper).Range.Address
End
Application.CutCopyMode = False
Next Lhyper
End If
Next ws
End Sub
How can i modify this to show the sheet name instead of the cell ref.
is it also possible to then check that these Hyperlinks are valid destinations?
You can get the name of the worksheet of the hyperlink with this line:
ws.Hyperlinks(Lhyper)..Range.Worksheet.Name
Here's is your reworked code (it contained some other syntactical errors that I corrected):
Sub CopyHyperLinks()
Dim rCell As Range
Dim ws As Worksheet
Dim Lhyper As Long
Dim rngLink As Range
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Hypers").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Sheets.Add().Name = "Hypers"
For Each ws In Worksheets
If ws.Name <> "Hypers" Then
For Lhyper = 1 To ws.UsedRange.Hyperlinks.Count
Set rngLink = ws.Hyperlinks(Lhyper).Range
rngLink.Copy
With Sheets("Hypers").Cells(Rows.Count, 1).End(xlUp)
.Offset(1, 0).PasteSpecial
.Offset(1, 1) = rngLink.Address
.Offset(1, 2) = rngLink.Worksheet.Name
.Offset(1, 3) = CheckHyperlink(ws.Hyperlinks(Lhyper).Address)
End With
Application.CutCopyMode = False
Next Lhyper
End If
Next ws
End Sub
If you want to verify the links, include the code from this answer. Include this line in your code:
.Offset(1, 3) = CheckHyperlink(ws.Hyperlinks(Lhyper).Address)
and also this routine:
Public Function CheckHyperlink(ByVal strUrl As String) As Boolean
Dim oHttp As New MSXML2.XMLHTTP30
On Error GoTo ErrorHandler
oHttp.Open "HEAD", strUrl, False
oHttp.send
If Not oHttp.Status = 200 Then CheckHyperlink = False Else CheckHyperlink = True
Exit Function
ErrorHandler:
CheckHyperlink = False
End Function
You need to include a reference to the "Microsoft XML" library in your VBA project.