I have very specific issue, I am trying to concat values to string using line break, I tried all possibilities, nothing works. I tried vbnewline, vbLf, CHR(10).
Range("M2:M" & AfterDuplastRow).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("M1").Select
ActiveCell.Offset(1, 0).Select
ActiveCell.Formula = _
"=IF(F2=""" & meal & """," & _
"IF(F1<>F2,B2,Concat(M1,CHR(10),B2)),"""")"
also I tried like this
ActiveCell.Formula = _
"=IF(F2=""" & meal & """," & _
"IF(F1<>F2,B2,Concat(M1," & CHR(10) & ",B2)),"""")"
Thank you for your help
Use constant vbNewLine:
ActiveCell.Formula = "=IF(F2=""" & meal & """,IF(F1<>F2,B2,Concat(M1," & vbNewLine & ",B2)),"""")"
This sounds like it may be an XY Problem...
Even if you include a New Line (vbNewLine), a Carriage Return (vbCr), a Line Feed (vbLf), or a Carriage Return and a Line Feed (vbCrLf), it will only be visible in a cell if Wrap Text is turned on for that cell.
As such, try this simple change:
Range("M2:M" & AfterDuplastRow).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("M1").Select
ActiveCell.Offset(1, 0).Select
ActiveCell.Formula = "=IF(F2=""" & meal & """," & _
"IF(F1<>F2,B2,Concat(M1,CHR(10),B2)),"""")"
Range("M1").WrapText = True 'This line should fix your issue
(Also, you may want to read up on How to avoid using Select in Excel VBA)
Related
I have to merge 2 cells where the range might vary at every run. I am trying with the below code, but there is some error with the code, which I am not able to identify. For fixed range its working fine, but for variable it is showing error. Line no is the cell number which needs to be merged, and it will vary at every run:
Range("D" & line_no & ":" "E" & line_no & ).Select
Range("D" & line_no).Activate
With Selection
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
I would try to get rid of the Select in general. You could do it like this:
With Range("D" & line_no & ":" & "E" & line_no)
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Your problem lies in string concatenation. Comments cover that part.
If this range would be used throughout the program, I'd recommend stroing this range in variable:
define string which will point desired range: Dim rng As String: rng = "D" & line_no & ":E" & line_no, then use it like this:
Range(rng).Select
Range(rng).Activate
OR
define range and store range in the variable instead of a string"
Dim rng As Range
Set rng = Range("D" & line_no & ":E" & line_no)
rng.Select
rng.Activate
'...
This is a little challenging to me
I have the following code which works just like I wanted. But I need the code to loop through Sheet1 Column A and copy and paste the value to Sheet2(R1) Then loop through Sheet1 column B and copy each value paste it to Sheet2(I7) then save the worksheet as a new PDF document
See Picture for example excel sheet
example
Sub Macro2()
'
' Macro2 Macro
'
'
Sheets("Sheet1").Select
Range("A2").Select
Selection.Copy
Sheets("Sheet2").Select
Range("R1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
With Selection.Font
.Name = "Calibri"
.Size = 20
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Sheets("Sheet1").Select
Range("B2").Select
Selection.Copy
Sheets("Sheet2").Select
Range("I7").Select
ActiveSheet.Paste
Application.CutCopyMode = False
With Selection.Font
.Name = "Calibri"
.Size = 16
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
Dim i As Integer
For i = 1 To 2
Next i
ThisWorkbook.Sheets("Sheet2").Select
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=ThisWorkbook.Path & "\" & CStr(i) & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=True, _
OpenAfterPublish:=False
End With
End Sub
You can use the following codes to loop through rows and/or columns if you add the function below at the end (below your actual sub) of the same "Module" your sub is located in.
sub yourcode
ThisWorkbook.Worksheets("worksheetX").range(col_letter(column_number) & rownumber).Value
end sub
Function col_letter(lngCol As Long) As String 'Sub nr_to_letter()
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
col_letter = vArr(0)
End Function
And it will automatically convert the column_number to the column letter in the .range("..
And the following generalized code detects the last row of your column:
'Find the last used row in a Column: column B in this example
Dim LastRow As Long
sheets(name(Sheet)).Select
sheets(name(Sheet)).Activate
'MsgBox (Sheet)
With ActiveSheet
LastRow = .Cells(.Rows.count, "B").End(xlUp).Row
End With
I learned a lot of the basics by looking up standard solutions to basic problems I stumbled upon from:
Source: http://www.rondebruin.nl/
And I think this code could perform your desired task:
Sub Macro2()
'
' Macro2 Macro
'
'
Sheets("Sheet1").Select
Range("A2").Select
'detect last row in column A sheet1:
Dim LastRow As Long
Sheets("Sheet1").Select
Sheets("Sheet1").Activate
'MsgBox (Sheet)
With ActiveSheet
LastRow_A = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
MsgBox (LastRow_A)
'here the function to convert column number to column letter is used:
'Range(col_letter(1) & "2:A" & LastRow).Select
MsgBox ("As you can see the function converts the index of the col_letter to a alphabetic letter: " & col_letter(1))
For loop_through_column_A = 2 To LastRow_A
Range(col_letter(1) & loop_through_column_A).Select
Selection.Copy
Sheets("Sheet2").Select
Range("R" & loop_through_column_A - 1).Select 'ensure it starts pasting at row 1
ActiveSheet.Paste
Application.CutCopyMode = False
With Selection.Font
.Name = "Calibri"
.Size = 20
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Next loop_through_column_A
Sheets("Sheet1").Select
Range("B2").Select
'detect last row in column B sheet1:
Dim LastRow_B As Long
Sheets("Sheet1").Select
Sheets("Sheet1").Activate
'MsgBox (Sheet)
With ActiveSheet
LastRow_B = .Cells(.Rows.Count, "B").End(xlUp).Row
End With
MsgBox (LastRow_B)
'loop through column Sheet1
For loop_through_column_B = 2 To LastRow_B
Range("B" & loop_through_column_B).Select
Selection.Copy
Sheets("Sheet2").Select
Range("I" & 5 + loop_through_column_B).Select
ActiveSheet.Paste
Application.CutCopyMode = False
With Selection.Font
.Name = "Calibri"
.Size = 16
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
'To save the pdf every iteration (after you have already completely iterated through column A in the first for-loop:
'"Insert here."
Next loop_through_column_B
'include this in the loop if you want to save the pdf every time you add a different pasted row where it says: "Insert here."
ThisWorkbook.Sheets("Sheet2").Select
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=ThisWorkbook.Path & "\" & CStr(i) & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=True, _
OpenAfterPublish:=False
End Sub
'Here the following function IS used:
Function col_letter(lngCol As Long) As String 'Sub nr_to_letter()
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
col_letter = vArr(0)
End Function
The following code loops through a bunch of .xlsx files in a folder and performs certain tasks such as insterting data validation in a specific cell range, conditional formatting within the same range and protecting the sheet and entire workbook to protect the integrity of the data. I would like to add one more piece of logic to the code below. I would like to add code to have a dialiog box pop up informing a user of a missed responses in the data validation range. So in simple terms, if person is required to enter a response (Y or N) in a cell for a given amount of rows misses one, a dialog box will pop up when he or she closes the Excel to let them know. I don't wan't to restrict the person from saving file. Just to let them know that a response was missed. Thank you!
Sub ProtectSheetsAndDataValidation()
'
' Access_Review_Final Macro
'
Dim MyFolder As String
Dim myFile As String
Dim wbk As Workbook
On Error Resume Next
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then 'If no folder is selected, abort
MsgBox "You did not select a folder"
Exit Sub
End If
MyFolder = .SelectedItems(1) & "\" 'Assign selected folder to MyFolder
End With
myFile = Dir(MyFolder) 'DIR gets the first file of the folder
'Loop through all files in a folder until DIR cannot find anymore
Do While myFile <> “”
'Opens the file and assigns to the wbk variable for future use
Set wbk = Workbooks.Open(FileName:=MyFolder & myFile)
'Replace the line below with the statements you would want your macro to perform
If Err.Number <> 0 Then
MsgBox ("Unable to open file " & myFile)
End If
On Error GoTo 0
Sheets(1).Select
Sheets(1).Name = "MAR"
Cells.Select
Range("K1").Activate
With Selection
.HorizontalAlignment = xlGeneral
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlGeneral
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
LastRow = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row
Range("A1").Select
Selection.Cut
Range("J1").Select
ActiveSheet.Paste
Range("K4:K" & LastRow).Select
Selection.Locked = False
Selection.FormulaHidden = False
Range("K4:K" & LastRow).Select
With Selection
.HorizontalAlignment = xlCenter
End With
Range("K4:K" & LastRow).Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("K4:K" & LastRow).Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=LEN(TRIM(K4))>0"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.Pattern = xlNone
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Range("J3").Select
Selection.Copy
Range("K3").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("K4").Select
Range("K4:K" & LastRow).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="Y,N,n,y"
.IgnoreBlank = False
.InCellDropdown = False
.InputTitle = ""
.ErrorTitle = "Invalid Response"
.InputMessage = "Please Enter ""Y"" or ""N"". Case doesn't matter."
.ErrorMessage = "Please Enter ""Y"" or ""N"". Case doesn't matter."
.ShowInput = True
.ShowError = True
End With
Range("K11").Select
Range("K16").Select
Rows("3:3").Select
Range("H3").Activate
Selection.AutoFilter
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingColumns:=True, AllowFormattingRows:=True, AllowSorting:= _
True, AllowFiltering:=True, Password:="adgiam"
ActiveWorkbook.Protect Structure:=True, Windows:=False, Password:="adgiam"
ActiveWindow.ScrollColumn = 9
wbk.Close SaveChanges:=True
myFile = Dir 'DIR gets the next file in the folder
Loop
Application.ScreenUpdating = True
MsgBox "Macro has completed! Woot! Woot!"
End Sub
you could use Workbook_BeforeClose event handler
what follows assumes that:
worksheet "Validation" is to be checked for missing validation
in worksheet "Validation", validation cells are in column K from row 4 down to last not empty row of column "B"
here's the code
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim cell As Range
Dim addrStrng As String
With Worksheets("Validations")
For Each cell In .Range("K4:K" & .Cells(.Rows.Count, "B").End(xlUp).Row)
With cell.Validation
.IgnoreBlank = False
If Not .Value Then addrStrng = addrStrng & cell.address(False, False) & vbCrLf
End With
Next cell
If addrStrng <> "" Then
MsgBox "There are validation data input missing in: " & vbCrLf & vbCrLf & addrStrng
Cancel = True
End If
End With
End Sub
With my code I want 2 perform formatting over several not adjacent COLUMNS, and I want to make it elegantly in code. Just as it's supposed to be by the book. I'm learning, so I want to learn the right way.
this is how my task looks like:
I've read this.
I mean... is there really no way to enumerate column letters in COLUMNS method? no way to do this?
So do I need to use RANGE object to preform my task? Is it correct?
How do I use UNION method in conjunction with "With... End With"
This is my case I guess.
Please explain more in detail than only 1,5 line answer please.
I will need to do the same things with Columns: B, C, G, H.
They will be formatted .NumberFormat = "#,##0.00"
Option Explicit
Dim VBA As Worksheet
Dim Filter As String
Dim Stock As Variant
Dim Index As Variant
Dim Portfolio As Variant
' Dim Date as Range
Sub Columns_Formatting()
Set VBA = Workbooks("kgh pricing model thursday.xlsm").Worksheets("VBA")
Filter = "Pliki CSV, *.csv," & "Pliki TXT, *.txt," & "All Files, *.*"
' Stock = Application.GetOpenFilename(fileFilter:=Filter, FilterIndex:=1, Title:="Choose file with a stock prices")
' Index = Application.GetOpenFilename(fileFilter:=Filter, FilterIndex:=1, Title:="Choose file with an index values")
' If Stock = False Or Index = False Then MsgBox "Canceled": Exit Sub
With VBA.Columns("A:A,F:F") ' here is the error = type mismath
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.NumberFormat = "yyyy-mm-dd;#"
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.ColumnWidth = 12
End With
With VBA.Columns("A;F")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.NumberFormat = "General"
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.ColumnWidth = 12
End With
With VBA.Range("E2:E" & Rows.Count)
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = True
.NumberFormat = "#,##0"
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.ColumnWidth = 10
End With
Use a Range object with full column references. You might also want to cut down the full column references to the Worksheet.UsedRange property with the Intersect method.
With VBA
With Intersect(.UsedRange, .Range("A:A,F:F"))
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.NumberFormat = "yyyy-mm-dd;#"
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.ColumnWidth = 12
End With
End With
All,
I call this subfunction within a loop in another subfunction. The loop works well without this sub called. When I call this sub, it works fine once, and then, on the second go, I get a "runtime error 5 - invalid procedure call or argument" here.
I have many sheets, each with a table. I want to summarize each table with a pivot table.
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
tblnm, Version:=xlPivotTableVersion10).CreatePivotTable _
TableDestination:=dest, TableName:=pivnm, _
DefaultVersion:=xlPivotTableVersion10
You can see the whole subfunction below.
Sub PIVOT()
Dim pivnm, shtnm, tblnm, dest As String
Application.EnableEvents = False
shtnm = ActiveSheet.Name
tblnm = Range("N2").Value 'I have previously sent the table name to this cell
pivnm = tblnm & " PIVOT"
tblnm = Replace(tblnm, " ", "_")
'The tables are named with underscores, but were stored with spaces
Range("N3") = pivnm
With Range("N3") 'simply wraps the text in the cell
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
dest = shtnm & "!R1C15" 'sets the destination
Sheets(shtnm).Select
Range("C1").Select
'the following was written using the macro recorder, with names replaced by
'variables
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
tblnm, Version:=xlPivotTableVersion10).CreatePivotTable _
TableDestination:=dest, TableName:=pivnm, _
DefaultVersion:=xlPivotTableVersion10
Sheets(shtnm).Select
Cells(1, 15).Select
With ActiveSheet.PivotTables(pivnm).PivotFields("Process text")
.Orientation = xlRowField
.Position = 1
End With
ActiveSheet.PivotTables(pivnm).AddDataField ActiveSheet.PivotTables( _
pivnm).PivotFields("Process text"), "Count of Process text", xlCount
ActiveSheet.PivotTables(pivnm).AddDataField ActiveSheet.PivotTables( _
pivnm).PivotFields("Column1"), "Sum of Column1", xlSum
With ActiveSheet.PivotTables(pivnm).DataPivotField
.Orientation = xlColumnField
.Position = 1
End With
With ActiveSheet.PivotTables(pivnm).PivotFields("Process text")
.Orientation = xlRowField
.Position = 1
End With
shtnm = vbNullString 'I tried resetting everything. Didn't work
tblnm = vbNullString
pivnm = vbNullString
dest = vbNullString
End Sub
Please let me know if I have left any information out or if there is anything I can do better!
I was asked to attach the loop from the other function - so here it is...It probably looks ridiculous to anyone but me...
While count3 <= count2
DoEvents
Application.StatusBar = "Updating. Sheet " & (count3) & " of 61 complete."
Sheets("Sheet2").Select
Selection.AutoFilter Field:=2
Selection.AutoFilter Field:=2, Criteria1:=Range("O" & CStr(count3)).Value
Range("A1:M" & CStr(count)).Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.count)
ActiveSheet.Paste
If Range("B2") <> "" Then
ActiveSheet.Name = Range("B2")
tblnm = Range("B2").Value
Sheets(tblnm).Select
Application.StatusBar = "Making Table" & (count3) & " of 61 complete."
While Range("B" & CStr(count4 + 1)) <> ""
count4 = count4 + 1
Wend
Range("N1").Value = count4
DataArea = ("$A$1:$M$" & count4)
DataArea1 = DataArea
ActiveWorkbook.ActiveSheet.ListObjects.Add(xlSrcRange, Range(DataArea1), , xlYes).Name = _
tblnm
ActiveWorkbook.ActiveSheet.ListObjects(tblnm).Range.AutoFilter Field:=5, Criteria1:= _
"=*UF_*", Operator:=xlAnd, Criteria2:="<>*Drive*"
ActiveSheet.ListObjects(tblnm).Range.AutoFilter Field:=8, Criteria1:= _
"<>#VALUE!", Operator:=xlAnd
ActiveWorkbook.Worksheets(tblnm).ListObjects(tblnm).Sort.SortFields.Add Key _
:=Range("M1:M" & CStr(count4)), SortOn:=xlSortOnValues, Order:=xlDescending, _
DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets(tblnm).ListObjects(tblnm).Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Call RhidRow
Columns("A:A").EntireColumn.Hidden = True
Columns("B:B").EntireColumn.Hidden = True
Columns("F:F").EntireColumn.Hidden = True
Columns("G:G").EntireColumn.Hidden = True
Columns("H:H").EntireColumn.Hidden = True
Columns("I:I").EntireColumn.Hidden = True
Columns("J:J").EntireColumn.Hidden = True
Columns("K:K").EntireColumn.Hidden = True
Columns("L:L").EntireColumn.Hidden = True
Columns("C:C").EntireColumn.AutoFit
Columns("D:D").EntireColumn.AutoFit
Columns("E:E").EntireColumn.AutoFit
Columns("M:M").EntireColumn.AutoFit
While Range("M" & CStr(count5 + 1)) <> ""
count5 = count5 + 1
Wend
Range("N2") = tblnm
With Range("N2")
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Call PIVOT
Else
ActiveSheet.Delete
End If
Range("A1").Select
count3 = count3 + 1
count4 = 2
count6 = 2
Wend
If your sheet names have spaces in them, you need:
dest = "'" & shtnm & "'!R1C15"
This is untested, but as an idea as to passing parameters:
Sub PIVOT(tblnm As String, ws As Worksheet)
Dim pivnm As String
Dim shtnm As String
Dim dest As String
Dim PT As PivotTable
Application.EnableEvents = False
With ws
shtnm = "'" & .Name & "'"
pivnm = tblnm & " PIVOT"
tblnm = Replace(tblnm, " ", "_")
'The tables are named with underscores, but were stored with spaces
With .Range("N3")
.Value = pivnm
'simply wraps the text in the cell
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End With
dest = shtnm & "!R1C15" 'sets the destination
'the following was written using the macro recorder, with names replaced by
'variables
Set PT = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
tblnm, Version:=xlPivotTableVersion10).CreatePivotTable( _
TableDestination:=dest, TableName:=pivnm, _
DefaultVersion:=xlPivotTableVersion10)
With PT
With .PivotFields("Process text")
.Orientation = xlRowField
.Position = 1
End With
.AddDataField .PivotFields("Process text"), "Count of Process text", xlCount
.AddDataField .PivotFields("Column1"), "Sum of Column1", xlSum
With .DataPivotField
.Orientation = xlColumnField
.Position = 1
End With
With .PivotFields("Process text")
.Orientation = xlRowField
.Position = 1
End With
End With
End Sub
and the calling code would use something like:
Call PIVOT(tblnm, wks)
where wks is a Worksheet variable set to whichever sheet has the data.