Related
#Modifying Question for better understanding and how do i want the result is.
Wizhi answer almost matched for my question !! But need some more
changes in his answer because which code is not working for me !! And
no need to work based on GCN Date as he answered. The split work
done based on Destination Pincode .
Please help someone help me to Macro Code for Split data into multiple sheet within an excel workbook based on a table format. Below is the explanation of how i have done as per my knowledge and what is my expectation is !!
"Here is the workbooks what i have Done"
Please download the Macro_Folder and Unzip it in you "C" Drive.
Open Macro Workbook and Press Button to run macro.
If it asked for updating formulas as shown in below picture please select "Don't Update" to continue macro.
My Macro workbook view :
I Have done button option to Run the split macro in separate excel workbook.
Where the files Located
When self open and run Macro from Macro Workbook it automatically opens my XD MIS Report and start formatting and split the date into multiple sheets.
View of XD MIS is "Master Data" which is having overall raw data.
Here is the view after self Run Macro fro split Master data.
Code that i Used For Split Data into Multiple Sheet:
Sub Spli_Data()
Dim wb As Workbook
Dim myfilename As String
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
myfilename = "C:\Macro\XD MIS Report.xlsx"
Set wb = Workbooks.Open(myfilename)
Cells.Select
Selection.EntireColumn.Hidden = False
Selection.EntireRow.Hidden = False
Columns("B:F").Select
Range("B2").Activate
Selection.Delete Shift:=xlToLeft
Columns("D:E").Select
Range("D2").Activate
Selection.Delete Shift:=xlToLeft
Columns("H:H").Select
Range("H2").Activate
Selection.Delete Shift:=xlToLeft
Columns("K:L").Select
Range("K2").Activate
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Delete Shift:=xlToLeft
Columns("D:D").Select
Range("D2").Activate
Selection.Cut
Selection.End(xlToRight).Select
Columns("K:K").Select
Range("K2").Activate
Selection.Insert Shift:=xlToRight
Selection.End(xlUp).Select
Range("K1").Select
ActiveCell.FormulaR1C1 = "Remarks"
Columns("J:J").Select
Selection.Copy
Columns("K:K").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Columns("H:H").Select
Selection.Insert Shift:=xlToRight
Range("H1").Select
ActiveCell.FormulaR1C1 = "Packing Type"
Range("H1").Select
Selection.End(xlToLeft).Select
Cells.Select
Selection.FormatConditions.Delete
Columns("B:B").Select
Selection.Copy
Columns("A:A").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("A2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=COUNTIF(R[-1]C[6]:RC[6],RC[6])"
Range("A2").Select
ActiveCell.FormulaR1C1 = "=COUNTIF(R1C7:RC[6],RC[6])"
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.FillDown
Selection.End(xlUp).Select
Columns("A:A").Select
Range("A2").Activate
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A2").Select
Application.CutCopyMode = False
Range("A1:L3100").Select
Range("A2").Activate
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection
.VerticalAlignment = xlBottom
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
With Selection
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
With Selection.Font
.Name = "Calibri"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
End With
With Selection.Font
.Name = "Calibri Light"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
.ThemeFont = xlThemeFontMajor
End With
Range("A2").Select
Application.ScreenUpdating = False
vcol = Application.InputBox(prompt:="Which column would you like to filter by?", title:="Filter column", Default:="3", Type:=1)
Set ws = ActiveSheet
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Next
ws.AutoFilterMode = False
ws.Activate
Application.ScreenUpdating = True
End Sub
Result Of Split Data What i have right now:
Destination 1
Destination 2
Now Let's Clear About My Requirement:
I have done macro for format and Split Data into multiple Sheet,But this the not exact format result which i'm looking for.
The split should be done in same method but for result format should be like below formats based on macro code.
The split data should be in Multiple sheets of within an Excel Workbook . Not split to multiple workbooks !!
Write a macro for split Data in this format for all Destination Pincode:
This how i'm expecting final result through macro code
Expected Format of #Destination 1 Sample After Split done
#Destination 1 Sample
This is an examples of what i'm looking for. The same have to done
for all destination which is in Master Data
Hope !! now my question is clear for better understanding and easy to answer.
Updated code:
#Mark Balhoff, Thanks for your valuable input, I always like to learn and get feedback to improve myself :). I have used your input in the code and also extended it a bit.
This code is using dictionary so you need to activate "Microsoft Scripting Runtime"
"Tools" -> "References" -> "Microsoft Scripting Runtime" to make dictionary work
User process to split Master Data:
I assume that the user will split this data in the picture:
Pressing the button, it will choose column 7.
(My opinion is that this part with InputBox etc... is unnecessary as you always want to filter by column 7 regardless, so I feel it confused the end user)
Is quite unclear from what "raw data" you start with as new pictures/data have appeared in the updated question. I have assumed that the data that we should split looks like this, as it was stated first
Output of the first unique Destination Pincode:
Output of the second unique Destination Pincode:
Code:
Option Explicit
Sub Split()
Dim lr As Long
Dim lc As Long
Dim ws As Worksheet
Dim ws_new As Worksheet
Dim DestPincode As Range
Dim DestPincodeCol As Long
Dim vcol As Long
Dim vcol_value As String
Dim vcol_name As String
Dim vcol_prompt As String
Dim i As Integer
Dim DestPincode_ws_new As Range
Dim DestPincodeCol_ws_new As Long
Dim DestPincodeRow_ws_new As Long
Application.ScreenUpdating = False
'##### SETTINGS #####
Set ws = ActiveWorkbook.Worksheets("Master_Data") 'Set master data sheet
Set DestPincode = ws.Range(ws.Cells(1, 1), ws.Cells(1, ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column)).Find(What:="Destination Pincode", LookIn:=xlValues, LookAt:=xlWhole) 'Set name to search after, i.e. Destination
'####################
lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column 'Find last column in Master Data
DestPincodeCol = DestPincode.Column 'Get column number for Destination Pincode
lr = ws.Cells(ws.Rows.Count, DestPincodeCol).End(xlUp).Row 'Get last row
'This macro splits data into multiple worksheets based on the variables on a column found in Excel.
'An InputBox asks you which columns you'd like to filter by, and it just creates these worksheets.
'##### Filter based on InputBox #####
vcol = Application.InputBox(prompt:="Which column would you like to filter by?", title:="Filter column", Default:="7", Type:=1)
If vcol <> 7 Then Exit Sub
'##### Get all the uniqe "Destination Pincodes" #####
' You need to activate "Tools" -> "References" -> "Microsoft Scripting Runtime" to make dictionary work
Dim DestPincodeData()
Dim UniqueDestPincodeData As Object
Dim DestPinRow As Long
Set UniqueDestPincodeData = CreateObject("Scripting.Dictionary")
DestPincodeData = Application.Transpose(ws.Range(ws.Cells(1, DestPincodeCol), ws.Cells(ws.Cells(Rows.Count, DestPincodeCol).End(xlUp).Row, DestPincodeCol))) 'Get all the Destination Pincode values
For DestPinRow = 2 To UBound(DestPincodeData, 1) 'Start from row 2 (to skip header) and add unique values to the dictionary
UniqueDestPincodeData(DestPincodeData(DestPinRow)) = 1 'Add value to dictionary
Next
'##### Loop through all the unqie Destination Pincodes and add to seperate workbooks #####
Dim new_wb As Workbook
Set new_wb = Application.Workbooks.Add 'Add new workbook
'Set new_wb = ActiveWorkbook
Dim DestPincodeName As Variant
Dim MyRangeFilter As Range
Set MyRangeFilter = ws.Range(ws.Cells(1, 1), ws.Cells(lr, lc)) 'Filter range 'Set filter range
For Each DestPincodeName In UniqueDestPincodeData.Keys 'Filter through all the unique names in dictionary "UniqueDestPincodeData"
'Debug.Print "Destination Pincode: " & DestPincodeName 'Print current unique Destination Pincode name
'Filter the data based on "Destination Pincode" and Column from InputBox
With MyRangeFilter
.AutoFilter Field:=DestPincodeCol, Criteria1:=DestPincodeName, Operator:=xlFilterValues 'Filter on Destination Pincode
End With
'##### Create new workbook for the filtered data #####
'To add to new worksheet:
Sheets.Add(After:=Sheets(Sheets.Count)).Name = DestPincodeName
Set ws_new = new_wb.Worksheets(DestPincodeName)
'##### Create template in the new workbook #####
'Building template output, row by row
ws_new.Range("A1:A7").Value = WorksheetFunction.Transpose( _
Array("*******", "TRIP NO", "TRIP DATE/TIME", "TRUCKTYPE (OWN/ATT/ADHOC)", "SEAL #", "SUPERVISOR NAME", "REMARK"))
ws_new.Range("H2:H6").Value = WorksheetFunction.Transpose( _
Array("VEHICLE NO", "VEHICLE CAPACITY", "DRIVER NAME", "DRIVER NO", "VENDOR NAME"))
Dim Top_Area_Cell_Format As Range
Set Top_Area_Cell_Format = ws_new.Range("A1:L1,A7:L7,A2:D2,E2:G2,H2:I2,J2:L2," _
& "A3:D3,E3:G3,H3:I3,J3:L3,A4:D4,E4:G4,H4:I4," _
& "J4:L4,A5:D5,E5:G5,H5:I5,J5:L5,A6:D6,E6:G6,H6:I6,J6:L6")
Application.DisplayAlerts = False
Top_Area_Cell_Format.Merge 'Merge cells
Top_Area_Cell_Format.HorizontalAlignment = xlLeft 'Make title in center
Top_Area_Cell_Format.Borders.LineStyle = xlContinuous 'Add border lines
Top_Area_Cell_Format.Font.Bold = True 'Add Bold text
ws_new.Range("A1:L1").HorizontalAlignment = xlCenter 'Make title in center
Application.DisplayAlerts = True
'##### Paste filtered data from Master_Data sheet #####
ws.Range(ws.Cells(1, 1), ws.Cells(lr, lc)).SpecialCells(xlCellTypeVisible).HorizontalAlignment = xlCenter 'Make text in center
ws.Range(ws.Cells(1, 1), ws.Cells(lr, lc)).SpecialCells(xlCellTypeVisible).EntireRow.Copy 'Copy entire row from filtered data
ws_new.Cells(8, "A").PasteSpecial xlPasteAll 'Paste all values including formats
Set DestPincode_ws_new = ws_new.Range(ws_new.Cells(8, 1), ws_new.Cells(1, ws_new.Cells(8, ws_new.Columns.Count).End(xlToLeft).Column)).Find(What:="Destination Pincode", LookIn:=xlValues, LookAt:=xlWhole) 'Set name to search after, i.e. Destination
DestPincodeCol_ws_new = DestPincode_ws_new.Column
DestPincodeRow_ws_new = ws_new.Cells(ws_new.Rows.Count, DestPincodeCol_ws_new).End(xlUp).Row
'Add total
ws_new.Cells(DestPincodeRow_ws_new + 1, "A").Value = "TOTAL"
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "A"), ws_new.Cells(DestPincodeRow_ws_new + 1, "G")).Merge 'Merge cells
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "A"), ws_new.Cells(DestPincodeRow_ws_new + 1, "G")).HorizontalAlignment = xlCenter 'Make text in center
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "A"), ws_new.Cells(DestPincodeRow_ws_new + 1, "G")).Borders.LineStyle = xlContinuous 'Add border lines
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "A"), ws_new.Cells(DestPincodeRow_ws_new + 1, "G")).Font.Bold = True 'Add Bold text
'Add total values
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "I"), ws_new.Cells(DestPincodeRow_ws_new + 1, "I")).Formula = "=SUM(I9:I" & DestPincodeRow_ws_new & ")" 'Add sum for "No. of cartons"
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "J"), ws_new.Cells(DestPincodeRow_ws_new + 1, "J")).Formula = "=SUM(J9:J" & DestPincodeRow_ws_new & ")" 'Add sum for "Actual weights"
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "H"), ws_new.Cells(DestPincodeRow_ws_new + 1, "L")).Borders.LineStyle = xlContinuous 'Add border lines
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "H"), ws_new.Cells(DestPincodeRow_ws_new + 1, "L")).Font.Bold = True 'Add Bold text
'##### Add sign boxes #####
Dim Bottom_Area_Cell_Text_Rng As String
Dim Bottom_Area_Cell_Format As String
Dim Bottom_Area_Cell_Format_rng As Range
Bottom_Area_Cell_Text_Rng = "B" & DestPincodeRow_ws_new + 2 & ":H" & DestPincodeRow_ws_new + 2
ws_new.Range(Bottom_Area_Cell_Text_Rng).Value = Array("Driver Signature", "", "Incharge Signature", "", "Security Signature", "", "REMARK")
Bottom_Area_Cell_Format = "A" & DestPincodeRow_ws_new + 2 & ":A" & DestPincodeRow_ws_new + 4 & "," _
& "B" & DestPincodeRow_ws_new + 2 & ":C" & DestPincodeRow_ws_new + 4 & "," _
& "D" & DestPincodeRow_ws_new + 2 & ":E" & DestPincodeRow_ws_new + 4 & "," _
& "F" & DestPincodeRow_ws_new + 2 & ":G" & DestPincodeRow_ws_new + 4 & "," _
& "H" & DestPincodeRow_ws_new + 2 & ":L" & DestPincodeRow_ws_new + 4
Set Bottom_Area_Cell_Format_rng = ws_new.Range(Bottom_Area_Cell_Format)
Application.DisplayAlerts = False
Bottom_Area_Cell_Format_rng.Merge 'Merge cells
Bottom_Area_Cell_Format_rng.HorizontalAlignment = xlLeft 'Make title in center
Bottom_Area_Cell_Format_rng.Borders.LineStyle = xlContinuous 'Add border lines
Bottom_Area_Cell_Format_rng.VerticalAlignment = xlTop 'Alignment of text
Bottom_Area_Cell_Format_rng.Font.Bold = True 'Add Bold text
Application.DisplayAlerts = True
'Adjust Column width
ws_new.Columns("A:L").Select
Selection.EntireColumn.AutoFit
Set ws_new = Nothing 'Reset worksheet value
Next
Application.DisplayAlerts = False
new_wb.Worksheets(1).Delete
Application.DisplayAlerts = True
On Error Resume Next
Sheet1.ShowAllData 'remove filter
On Error GoTo 0
ws.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub
Link to workbook:
https://www.dropbox.com/s/86wlv99y6wylpn8/split%20data.xlsm?dl=0
I'm not sure If I've understand properly, but it looks like you want to split your data depending on the value of PINCODE column.
Besides, your question is too broad right now, you should focus more.
So, as example, I understand you would select all rows containing PINCODE=PUZHAL, and copy all of them into a different workbook.
And you want this for each unique PINCODE.
I made a fake dataset coloring rows, and I split the data into new workbooks. You'll need to adapt this to paste the data into existing workbooks (or new worksheets of same workbook, whatever)
My data is like this:
My code:
Sub TEST()
Application.ScreenUpdating = False
Dim MyDict As Object
Dim i As Long
Dim MyKey As Variant
Dim LR As Long
Dim WB As Workbook
Dim MyRows As Variant
LR = Range("G" & Rows.Count).End(xlUp).Row
Set MyDict = CreateObject("Scripting.Dictionary")
For i = 2 To LR Step 1
If MyDict.Exists(Range("G" & i).Value) = False Then
'we create the PINCODE in Dictionary and assign row number
MyDict.Add Range("G" & i).Value, i
Else
'PINCODE already in Dictionary, we add the new row number
MyDict(Range("G" & i).Value) = MyDict(Range("G" & i).Value) & "|" & i
End If
Next i
'now Dictionary holds all pincodes and all row numbers for each pincode.
'we create a workbook for each PINCODE, but you can adapt this to open a exact workbook depending on PINCODE
'I'm copying the rows starting at row 1, but you can adapt this to your model for sure
For Each MyKey In MyDict.Keys
Set WB = Application.Workbooks.Add
LR = 1 'change this to starting row
MyRows = Split(MyDict(MyKey), "|") 'we create array of rows numbers
For i = LBound(MyRows) To UBound(MyRows) Step 1
'we copy range A:L from that row into destiny workbook
ThisWorkbook.ActiveSheet.Range("A" & MyRows(i) & ":L" & MyRows(i)).Copy WB.ActiveSheet.Range("A" & LR & ":L" & LR)
LR = LR + 1 'we increase LR so next data will be pasted into next row
Next i
Erase MyRows
Set WB = Nothing
DoEvents
Next MyKey
MyDict.RemoveAll
Set MyDict = Nothing
Application.ScreenUpdating = True
End Sub
And this is how i get all my data splitted into different files depending on PINCODE.
I suggest You create a Pivot Table.
By that Pivot table you create a code to extract data on a pivotable base on a list and transfer that to the formatted workbook you created and make a loop until the last Destination Pincode. I also use Excel VBA Form to Trigger this. I can make you one if you post your Excel here.
I've created a macro that transfers the selected value from the dropdown list to the sheet with the same name as the value. I recommend that you review it.
Source : Split data into multiple sheets
I'm not a rookie but not yet a pro on VBA Excel and I have encounter myself with a problem I have being struggling for a while.
Tried on google and this forum to read some data for a guide or the answer without success so I'll explain it to you hoping someone can give me a hint or enlightenment.
I want to code a VBA Macro that creates a Sheet from my Database called "ClientProperties" in which I'll create a Pivot Table "PT2" containing all the client names on a filtered state/Country and some properties like promotions name applied for that client, and the promotion value sorted by month. Then It will create a new sheet with the name of every state/Country on my Database but in each sheet I have to create one Pivot Table for each client ("PT1", "PT2", ... "PTn") showing the product categories that client has and sales sorted by month; Below that Pivot table I have to paste the properties from the "PT2" for that client.
I can create the "PT2", apply the filters and sort the information as needed without any problems but when I try to create the "PT1" it shows the error:
"Error '5' has occurred at runtime:
Invalid argument or procedure call".
The fist Pivot is actually created like this:
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "ClientProperties"
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="Base!R1C1:R50C100"_
Version:=6).CreatePivotTable TableDestination:="ClientProperties!R3C1", TableName:="DT1", DefaultVersion:=6
The second (The one with error) like this (Note: PL(X) is an array of strings [state/Country name]):
For X = 0 To UBound(PL, 1)
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "" & PL(x) & ""
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="Base!R1C1:R50C100"_
Version:=6).CreatePivotTable TableDestination:="" & PL(X) & "R8C23", TableName:="DT2", DefaultVersion:=6
Here is my code resumed:
Global LBD As Long, ABD As Integer, LBB As Long, ABB As Integer, PL(11) As String, CA() As String, AN As String, CTE As Boolean, TR As String * 1, FBB As Integer
Global ASS() As String, CAP() As String, FTD As Integer, ITD As Boolean, LTD As Integer, PN As String * 1, CRK As Integer, CANCEL As Boolean
Sub Main()
Call Variables
Worksheets("Base").Visible = True
Worksheets("Base").Select
LBD = Rows(1, 1)
ABD = Columns(1, 1)
Call AditionalProcess
Call ClientProps
Call SummaryTabs
Worksheets("Base").Visible = False
Worksheets("ClientProperties").Visible = False
End Sub
The Other modules are:
Sub Variables()
If TR = "M" Then
CTE = True
ReDim CA(3) As String
CA(0) = "Club"
CA(1) = "Conv"
CA(2) = "Reg"
CA(3) = "Ret"
Else
CTE = False
ReDim CA(3) As String
CA(0) = "Whs"
CA(1) = "C3"
CA(2) = "C5"
CA(3) = "Dist"
End If
PL(0) = "CALIFORNIA"
PL(1) = "FLORIDA"
If TR = "M" Then PL(2) = "AUSTIN" Else PL(2) = "HOUSTON"
PL(3) = "HAWAI"
PL(4) = "NEW JERSEY"
PL(5) = "ARIZONA"
PL(6) = "PENSILVANIA"
PL(7) = "VIRGINIA"
PL(8) = "MICHIGAN"
PL(9) = "GEORGIA"
PL(10) = "COLORADO"
PL(11) = "OHIO"
End Sub
Function Rows(X As Long, Y As Integer) As Long
Do While Cells(X, Y) <> Empty
X = X + 1
Loop
Rows = X - 1
End Function
Function Columns(X As Long, Y As Integer) As Long
Do While Cells(X, Y) <> Empty
Y = Y + 1
Loop
Columns = Y - 1
End Function
Sub AditionalProcess()
Worksheets("Base").Select
Range(Cells(2, 8), Cells(LBD, 8)).Copy
Sheets.Add After:=ActiveSheet
ActiveSheet.Paste
Application.CutCopyMode = False
Columns("A:A").RemoveDuplicates Columns:=1, Header:=xlNo
ReDim CAP(20) As String
For Y = 1 To 20
CAP(Y - 1) = Range(Cells(Y, 1), Cells(Y, 1))
Next Y
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
End Sub
Sub ClientProps()
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "ClientProperties"
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="Base!R1C1:R" & LBD & "C" & ABD & "", Version:=6).CreatePivotTable TableDestination:="ClientProperties!R3C1", TableName:="PT2", DefaultVersion:=6
Sheets("BB´s").Select
Cells(3, 1).Select
With ActiveSheet.PivotTables("PT2")
.ColumnGrand = True
.HasAutoFormat = True
.DisplayErrorString = False
.DisplayNullString = True
.EnableDrilldown = True
.ErrorString = ""
.MergeLabels = False
.NullString = ""
.PageFieldOrder = 2
.PageFieldWrapCount = 0
.PreserveFormatting = True
.RowGrand = True
.SaveData = True
.PrintTitles = False
.RepeatItemsOnEachPrintedPage = True
.TotalsAnnotation = False
.CompactRowIndent = 1
.InGridDropZones = False
.DisplayFieldCaptions = True
.DisplayMemberPropertyTooltips = False
.DisplayContextTooltips = True
.ShowDrillIndicators = True
.PrintDrillIndicators = False
.AllowMultipleFilters = False
.SortUsingCustomLists = True
.FieldListSortAscending = False
.ShowValuesRow = False
.CalculatedMembersInFilters = False
.RowAxisLayout xlCompactRow
.PageFieldOrder = xlDownThenOver
End With
With ActiveSheet.PivotTables("PT2").PivotCache
.RefreshOnFileOpen = False
.MissingItemsLimit = xlMissingItemsDefault
End With
ActiveSheet.PivotTables("PT2").RepeatAllLabels xlRepeatLabels
With ActiveSheet.PivotTables("PT2").PivotFields("FY")
.Orientation = xlPageField
.Position = 1
End With
With ActiveSheet.PivotTables("PT2").PivotFields("Client")
.Orientation = xlPageField
.Position = 1
End With
With ActiveSheet.PivotTables("PT2")
.ColumnGrand = False
.RowGrand = False
End With
ActiveSheet.PivotTables("PT2").AddDataField ActiveSheet.PivotTables("PT2").PivotFields("M01"), " M01", xlSum
ActiveSheet.PivotTables("PT2").AddDataField ActiveSheet.PivotTables("PT2").PivotFields("M02"), " M02", xlSum
ActiveSheet.PivotTables("PT2").AddDataField ActiveSheet.PivotTables("PT2").PivotFields("M03"), " M03", xlSum
ActiveSheet.PivotTables("PT2").AddDataField ActiveSheet.PivotTables("PT2").PivotFields("M04"), " M04", xlSum
ActiveSheet.PivotTables("PT2").AddDataField ActiveSheet.PivotTables("PT2").PivotFields("M05"), " M05", xlSum
ActiveSheet.PivotTables("PT2").AddDataField ActiveSheet.PivotTables("PT2").PivotFields("M06"), " M06", xlSum
ActiveSheet.PivotTables("PT2").AddDataField ActiveSheet.PivotTables("PT2").PivotFields("M07"), " M07", xlSum
ActiveSheet.PivotTables("PT2").AddDataField ActiveSheet.PivotTables("PT2").PivotFields("M08"), " M08", xlSum
ActiveSheet.PivotTables("PT2").AddDataField ActiveSheet.PivotTables("PT2").PivotFields("M09"), " M09", xlSum
ActiveSheet.PivotTables("PT2").AddDataField ActiveSheet.PivotTables("PT2").PivotFields("M10"), " M10", xlSum
ActiveSheet.PivotTables("PT2").AddDataField ActiveSheet.PivotTables("PT2").PivotFields("M11"), " M11", xlSum
ActiveSheet.PivotTables("PT2").AddDataField ActiveSheet.PivotTables("PT2").PivotFields("M12"), " M12", xlSum
With ActiveSheet.PivotTables("PT2").PivotFields("PROMOS")
.Orientation = xlRowField
.Position = 1
End With
LBB = Rows(8, 1)
ABB = Columns(7, 1)
Range(Cells(8, 2), Cells(LBB, ABB)).Style = "Comma"
Range(Cells(8, 2), Cells(LBB, ABB)).NumberFormat = "_-* #,##0_-;-* #,##0_-;_-* ""-""??_-;_-#_-"
ActiveSheet.PivotTables("PT2").PivotFields("PROMOS").Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
ActiveWorkbook.ShowPivotTableFieldList = False
End Sub
Sub SummaryTabs()
For X = 0 To UBound(PL, 1)
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "" & PL(X) & ""
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="Base!R1C1:R" & LBD & "C" & ABD & "", Version:=6).CreatePivotTable TableDestination:="" & PL(X) & "!R8C23", TableName:="PT1." & (X+2), DefaultVersion:=6
End Sub
At this point is where the error message appears and that's why i cut the code...
Two things:
you are missing '!' before the range in loop (!R8C23 instead of R8C23)
PivotTable name is the same in the loop, that will not work
Also you can use the same PivotCache for all the pivots, as it's always the same, like here (this code has both issues fixed):
Dim ws As Worksheet
Set ws = Sheets.Add(After:=ActiveSheet)
ws.Name = "ClientProperties"
Dim pc as PivotCache
Set pc = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="Base!R1C1:R50C100", _
Version:=6)
pc.CreatePivotTable TableDestination:="ClientProperties!R3C1", TableName:="DT1", DefaultVersion:=6
For X = 0 To UBound(PL, 1)
Set ws = Sheets.Add(After:=ActiveSheet)
ws.Name = "" & PL(x) & ""
pc.CreatePivotTable TableDestination:="" & PL(X) & "!R8C23", TableName:="DT" & (X+2), DefaultVersion:=6
I Just found the answer:
The sheet name in:
TableDestination:="" & PL(X) & "!R8C23"
needs to be surrounded with single quotes in order for it to work:
TableDestination:="'" & PL(X) & "'!R8C23"
Thank you all for your support!!!
I have a workbook already with a macro that does several things based on a cell value:
When i change a cell value (its a store name) the code will filter several sheets with, just to show the store of that specific cell, then hides several sheets.
Just showing 2 specific sheets.
And in the end of the code i save a new workbook with the name of that store.
My question is:
Is it possible to change my code (shown below), so i dont have to write manually the name of the store, ie, i want that the macro sees a list of stores, then change the cell with each store, do all the tasks i want, and then writes a new workbook with that store name, and so on, until the end of the list store?
Thank you so much
(PS: im new in vba, so my code probably is a little rough around the edges)
Sub Nova_loja()
Dim sht As Worksheet
Dim Fname As String
Dim Cell As Range, cRange As Range
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
'copy past in values
With Range("K44:L66")
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
End With
Application.CutCopyMode = False
'filter and delete
Sheets("BD Geral").Select
ActiveSheet.ListObjects("Table2").Range.AutoFilter Field:=52, Criteria1:="<>" & Worksheets("Tabela - Média Mensal").Range("B2").value, Operator:=xlFilterValues
Application.DisplayAlerts = False
ActiveSheet.ListObjects("Table2").DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
ActiveSheet.ListObjects("Table2").AutoFilter.ShowAllData
'filter and delete
Sheets("BD BONUS_MALUS").Select
ActiveSheet.ListObjects("Table35").Range.AutoFilter Field:=3, Criteria1:="<>" & Worksheets("Tabela - Média Mensal").Range("B1").value, Operator:=xlFilterValues
Application.DisplayAlerts = False
ActiveSheet.ListObjects("Table35").DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
ActiveSheet.ListObjects("Table35").AutoFilter.ShowAllData
'filter and delete
Sheets("BD NPS").Select
ActiveSheet.ListObjects("Table3").Range.AutoFilter Field:=2, Criteria1:="<>" & Worksheets("Tabela - Média Mensal").Range("B1").value, Operator:=xlFilterValues
Application.DisplayAlerts = False
ActiveSheet.ListObjects("Table3").DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
ActiveSheet.ListObjects("Table3").AutoFilter.ShowAllData
Sheets("BD Dept").Select
ActiveSheet.ListObjects("Table4").Range.AutoFilter Field:=8, Criteria1:="<>" & Worksheets("Tabela - Média Mensal").Range("B1").value, Operator:=xlFilterValues
Application.DisplayAlerts = False
ActiveSheet.ListObjects("Table4").DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
ActiveSheet.ListObjects("Table4").AutoFilter.ShowAllData
'refresh pivots
ThisWorkbook.RefreshAll
'hide sheets
For Each sht In ThisWorkbook.Worksheets
If sht.Name <> "Dashboard" And sht.Name <> "Tabela - Média Mensal" Then
sht.Visible = xlSheetVeryHidden
End If
Next sht
'protect sheets
For Each sht In ActiveWorkbook.Sheets
sht.Protect Password:="fnacrh", AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True
Next
'leave active main worksheet
Sheets("Dashboard").Select
'save as with new name
Application.DisplayAlerts = False
Fname = ThisWorkbook.Path & "\" & "02.VIM_REPORT MENSAL - " & Worksheets("aux").Range("V2") & " - " & Worksheets("aux").Range("V3") & ".xlsx"
ActiveWorkbook.SaveAs Filename:=Fname, FileFormat:=xlWorkbookDefault
Application.DisplayAlerts = True
Application.DisplayStatusBar = True
Application.ScreenUpdating = True
End Sub
Thank you so much
The next code would do what I understood you need.
Copy the next code in a module of another workbook, different from the one to be processed, and run AutomaticallySelectStore procedure. An InputBox will appear asking to select the number from the right side of the workbook name to be processed.
Sub AutomaticallySelectStore()
Dim w As Workbook, Wb As Workbook, sh As Worksheet, store As Variant, Arr As Variant, Ans As String
Dim i As Long, strWorkb As String, strWbName As String, strWbPath As String, nrStores As Long
strWorkb = "Please write the number of the workbook needed to be processed:" & vbCrLf & vbCrLf
For Each Wb In Workbooks
i = i + 1
strWorkb = strWorkb & Wb.name & " - " & i & vbCrLf
Next
strWorkb = left(strWorkb, Len(strWorkb) - 1)
Ans = InputBox(strWorkb, "Necessary workbook selection", 1)
If Ans = "" Then MsgBox "You did not select anything...", vbInformation, "No workbook selected": Exit Sub
If Not IsNumeric(Ans) Then
MsgBox "You must write the number from the right side of the needed workbook name!", vbInformation, _
"Wrong choice...": Exit Sub
ElseIf Ans > Workbooks.Count Then
MsgBox "You must write a number less or equal with " & Workbooks.Count, vbInformation, _
"Wrong chosen number": Exit Sub
End If
Set w = Workbooks(CLng(Ans))
On Error Resume Next
Set sh = w.Worksheets("aux")
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0
MsgBox "The chosen workbook looks to be wrong..." & vbCrLf & _
" Worksheet ""Tabela - Média Mensal"" is missing.", vbInformation, _
"Wrong workbook or necessary worksheet missing": Exit Sub
End If
On Error GoTo 0
strWbName = w.FullName
nrStores = sh.Range("AF2").End(xlDown).Row
Arr = sh.Range("AF2:AF" & nrStores)
w.Activate
i = 0
Application.Calculation = xlCalculationManual
For Each store In Arr
i = i + 1
Nova_loja strWbName, store, i, nrStores - 1
Next
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = "Ready..."
End Sub
Sub Nova_loja(strWbName As String, store As Variant, No As Long, NrPag As Long)
Dim sht As Worksheet, fName As String, Cell As Range, cRange As Range
Dim w As Workbook, Wb As Workbook, boolFound As Boolean, shortName As String
Dim Arr As Variant, shAr As Worksheet, shortWbName As String
shortWbName = Right(strWbName, Len(strWbName) - InStrRev(strWbName, "\"))
For Each Wb In Workbooks
If Wb.FullName = strWbName Then
Set w = Wb: boolFound = True: Exit For
End If
Next
If Not boolFound Then
Set w = Workbooks.Open(strWbName)
End If
Application.ScreenUpdating = False
Application.StatusBar = "Working on " & store & " store (" & No & " of " & NrPag & ")..."
Application.CalculateBeforeSave = True
Set shAr = Workbooks(shortWbName).Worksheets("aux")
Arr = shAr.Range("K44:L66")
shAr.Range("K44:L66") = Arr
Sheets("Tabela - Média Mensal").Range("B2").Value = store
Sheets("BD Geral").ListObjects("Table2").Range.AutoFilter field:=52, Criteria1:="<>" & store, _
Operator:=xlFilterValues
Application.DisplayAlerts = False
Sheets("BD Geral").ListObjects("Table2").DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Sheets("BD Geral").ListObjects("Table2").AutoFilter.ShowAllData 'it returns an error if no filter is applied
Application.DisplayAlerts = True
'filter and delete
Sheets("BD BONUS_MALUS").ListObjects("Table35").Range.AutoFilter field:=3, Criteria1:="<>" & Worksheets("Tabela - Média Mensal").Range("B1").Value, Operator:=xlFilterValues
Application.DisplayAlerts = False
Sheets("BD BONUS_MALUS").ListObjects("Table35").DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
Sheets("BD BONUS_MALUS").ListObjects("Table35").AutoFilter.ShowAllData
'filter and delete
Sheets("BD NPS").ListObjects("Table3").Range.AutoFilter field:=2, Criteria1:="<>" & Worksheets("Tabela - Média Mensal").Range("B1").Value, Operator:=xlFilterValues
Application.DisplayAlerts = False
Sheets("BD NPS").ListObjects("Table3").DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
Sheets("BD NPS").ListObjects("Table3").AutoFilter.ShowAllData
'This sheet does not contain any "Table"...
Sheets("BD Dept").ListObjects("Table4").Range.AutoFilter field:=8, Criteria1:="<>" & Worksheets("Tabela - Média Mensal").Range("B1").Value, Operator:=xlFilterValues
Application.DisplayAlerts = False
Sheets("BD Dept").ListObjects("Table4").DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
Sheets("BD Dept").ListObjects("Table4").AutoFilter.ShowAllData
'hide sheets
For Each sht In w.Worksheets
If sht.name <> "Dashboard" And sht.name <> "Tabela - Média Mensal" Then
sht.Visible = xlSheetVeryHidden
End If
Next sht
'protect sheets
For Each sht In ActiveWorkbook.Sheets
sht.Protect Password:="fnacrh", AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True
Next
'leave active main worksheet
Sheets("Dashboard").Select
w.RefreshAll
shortName = "02.VIM_REPORT MENSAL - " & store & " - " & Worksheets("aux").Range("V3") & ".xlsx"
fName = w.Path & "\" & shortName
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=fName, FileFormat:=xlWorkbookDefault
Workbooks(shortName).Close , False
Application.DisplayAlerts = True
Application.DisplayStatusBar = True
Application.ScreenUpdating = True
End Sub
Please, test it and confirm if it works as expected.
If not, mention what wrong happens.
Would that 'list of stores' be another excel workbook/sheet?
Do we have to deduce where the 'store' in discussion exists in your workbook?
Isn't it better you to describe where the change must be done?
Of course, this is not an answer but I do not know how else I can clarify the issue...
Sub AutomaticallySelectStore()
Dim W As Workbook, Sh As Worksheet, store As Variant, Arr As Variant
Set W = ActiveWorkbook
Set Sh = W.Worksheets("Tabela - Média Mensal")
Arr = Sh.Range("AF2:AF" & Sh.Range("AF2").SpecialCells(xlCellTypeLastCell).Row)
For Each store In Arr
Nova_loja store
Next
End Sub
Sub Nova_loja(store As Variant)
Dim sht As Worksheet, Fname As String, Cell As Range, cRange As Range
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
With Range("K44:L66")
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
End With
Application.CutCopyMode = False
'filter and delete
Sheets("BD Geral").Select
ActiveSheet.ListObjects("Table2").Range.AutoFilter Field:=52, Criteria1:="<>" & store, Operator:=xlFilterValues
Application.DisplayAlerts = False
ActiveSheet.ListObjects("Table2").DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
ActiveSheet.ListObjects("Table2").AutoFilter.ShowAllData
'filter and delete
Sheets("BD BONUS_MALUS").Select
ActiveSheet.ListObjects("Table35").Range.AutoFilter Field:=3, Criteria1:="<>" & Worksheets("Tabela - Média Mensal").Range("B1").Value, Operator:=xlFilterValues
Application.DisplayAlerts = False
ActiveSheet.ListObjects("Table35").DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
ActiveSheet.ListObjects("Table35").AutoFilter.ShowAllData
'filter and delete
Sheets("BD NPS").Select
ActiveSheet.ListObjects("Table3").Range.AutoFilter Field:=2, Criteria1:="<>" & Worksheets("Tabela - Média Mensal").Range("B1").Value, Operator:=xlFilterValues
Application.DisplayAlerts = False
ActiveSheet.ListObjects("Table3").DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
ActiveSheet.ListObjects("Table3").AutoFilter.ShowAllData
Sheets("BD Dept").Select
ActiveSheet.ListObjects("Table4").Range.AutoFilter Field:=8, Criteria1:="<>" & Worksheets("Tabela - Média Mensal").Range("B1").Value, Operator:=xlFilterValues
Application.DisplayAlerts = False
ActiveSheet.ListObjects("Table4").DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
ActiveSheet.ListObjects("Table4").AutoFilter.ShowAllData
'refresh pivots
ThisWorkbook.RefreshAll
'hide sheets
For Each sht In ThisWorkbook.Worksheets
If sht.Name <> "Dashboard" And sht.Name <> "Tabela - Média Mensal" Then
sht.Visible = xlSheetVeryHidden
End If
Next sht
'protect sheets
For Each sht In ActiveWorkbook.Sheets
sht.Protect Password:="fnacrh", AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True
Next
'leave active main worksheet
Sheets("Dashboard").Select
'save as with new name
Application.DisplayAlerts = False
Fname = ThisWorkbook.Path & "\" & "02.VIM_REPORT MENSAL - " & Worksheets("aux").Range("V2") & " - " & Worksheets("aux").Range("V3") & ".xlsx"
ActiveWorkbook.SaveAs Filename:=Fname, FileFormat:=xlWorkbookDefault
Application.DisplayAlerts = True
Application.DisplayStatusBar = True
Application.ScreenUpdating = True
End Sub
So, you must run 'AutomaticallySelectStore' procedure and wait...
I do not have such a file in order to test it, so, it is a code based only on VBA logic and my understanding about your situation.
Depending on how big are your workbooks it may load your system RAM and CPU, working continuously. I am waiting for some feedback.
The initial code can also be optimized a little, but let us see how it works now.
I know variations of this question have been asked but I can't seem to find the right code to accomplish this task. I have 2 tabs, Master Summary and Master Detail, from which I would like to copy data based on cell values in columns K and G respectively. I would like to copy data from both tabs into a new workbook if the values where these columns match. Each value needs its own workbook to be saved as the name in the cell.
Thanks
Here is what I came up with:
Sub CopyCMOsToOwnWorkbooks()
Application.EnableCancelKey = xlDisabled
Application.ScreenUpdating = False
Dim CMO As Variant
Dim CMOS As Variant
Dim wbDest As Workbook
Dim RAF As Workbook
Set RAF = ThisWorkbook
Dim rng As Range
Set rng = Range(Range("A1"), Range("A1").SpecialCells(xlLastCell))
CMOS = Array("Element Care", "CCACG EAST", "SCMO", "CCACG WEST", "Uphams Corner Hlth Cent", "CCC-Boston", "Vinfen", "Behavioral Hlth Ntwrk", _
"CommH Link Worc", "Long Term Care CMO", "Advocates, Inc", "CCC-Springfield", "BU Geriatric Service", "Lynn Comm HC", "CCA-BHI", "BIDJP Subacute", _
"CCC-Lawrence", "CCC-Framingham", "East Boston Neighborhoo", "BosHC 4 Homeless", "Bay Cove Hmn Srvces", "Mailhoit, Carrie", "Brightwood Hlth Ctr-Bay", _
"Romero, Michele", "Isaacs, Cindy", "McCoy, Viola", "ADRC of Greater North Shore", "Geller, Marian")
For Each CMO In CMOS
On Error Resume Next
RAF.Activate
Application.CutCopyMode = False
Sheets("MASTER Summary").Select
Range("F12").Select
Selection.AutoFilter
ActiveSheet.ListObjects("Table_Query_from_ProdServerP052").Range.AutoFilter _
Field:=11, Criteria1:=CMO
Cells.Select
Selection.Copy
Set wbDest = Workbooks.Add(xlWBATWorksheet)
ActiveSheet.Paste
ActiveSheet.Cells.Select
Selection.ColumnWidth = 8.29
Cells.EntireColumn.AutoFit
Selection.ColumnWidth = 78.71
Cells.EntireRow.AutoFit
Cells.EntireColumn.AutoFit
Sheets("Sheet1").Select
Sheets("Sheet1").Name = "Summary"
Range("C24").Select
ActiveSheet.ListObjects.Add(xlSrcRange, rng, , xlYes).Name = _
"Table1"
Range("Table1[#All]").Select
ActiveSheet.ListObjects("Table1").TableStyle = "TableStyleLight13"
RAF.Activate
Application.CutCopyMode = False
Sheets("MASTER Detail").Select
Range("A2").Select
Selection.AutoFilter
ActiveSheet.ListObjects("Table_Query_from_ProdServerP054").Range.AutoFilter _
Field:=7, Criteria1:=CMO
Cells.Select
Selection.Copy
wbDest.Activate
Sheets.Add After:=ActiveSheet
Range("A1").Select
ActiveSheet.Paste
Cells.Select
Selection.ColumnWidth = 34.29
Selection.ColumnWidth = 50.71
Cells.EntireRow.AutoFit
Cells.EntireColumn.AutoFit
wbDest.Sheets("Sheet2").Select
wbDest.Sheets("Sheet2").Name = "Detail"
ActiveSheet.ListObjects.Add(xlSrcRange, rng, , xlYes).Name = _
"Table2"
Range("Table2[#All]").Select
ActiveSheet.ListObjects("Table1").TableStyle = "TableStyleLight13"
Range("A13").Select
wbDest.Sheets("Summary").Select
Application.DisplayAlerts = False
wbDest.SaveAs ThisWorkbook.Path & Application.PathSeparator & _
CMO & " " & Format(Date, "mmm_dd_yyyy")
Application.DisplayAlerts = True
wbDest.Close
Next CMO
End Sub
I made a VBA macro that generates a MailMerge from an Excel spreadsheet creating the new document in Word.
I need to run a Find and Replace on a particular phrase ('ANTHXXXX') in the Word document with the user input variable InputtedModuleCode.
The macro runs without errors, but I can't get it to find and replace. I have included the entire macro script below. The relevant line of the script is underneath the comment:
' find and replace module code
...about 10 lines from the bottom of the script.
Sub AAMerge()
'
' AAMerge Macro
'
'
'Prompt user to input Module Code
Dim InputtedModuleCode As String
InputtedModuleCode = InputBox("Enter Module Code here, e.g. ANTH1001")
'Prompt user to input Module Code
Dim InputtedSubmissionDeadline As String
InputtedSubmissionDeadline = InputBox("Enter essay submission deadline. Must be format dd/mm/yyyy hh:mm:ss")
'Copy data into new spreadsheet
Cells.Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Application.CutCopyMode = False
With Selection.Font
.Name = "Arial"
.Size = 12
.StrikeThrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
End With
With Selection.Font
.Name = "Arial"
.Size = 10
.StrikeThrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
End With
' Move GradeMark Grade Column
Columns("H:H").Select
Selection.Copy
Columns("P:P").Select
ActiveSheet.Paste
' Delete Overlap/Internet Overlap/Publications Overlap/Student Papers Overlap columns
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft
Selection.Delete Shift:=xlToLeft
Columns("F:J").Select
Selection.Delete Shift:=xlToLeft
' insert Portico SCN formula
Range("F2").Select
ActiveCell.FormulaR1C1 = "SCN (Portico)"
Range("F3").Select
ActiveCell.FormulaR1C1 = "=IFERROR(VLOOKUP((UPPER(CONCATENATE(RC[-5],""_"",(LEFT(RC[-4],1)),""_" & InputtedModuleCode & """))),'N:\EssaySubTrial\[Student List 201213.xls]Sheet1'!C1:C9,6,FALSE),"""")"
Range("F3").Select
Dim LR As Integer
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("F3").AutoFill Destination:=Range("F3:F" & LR), Type:=xlFillDefault
' insert Portico student email
Range("G2").Select
ActiveCell.FormulaR1C1 = "Email (Portico)"
Range("G3").Select
ActiveCell.FormulaR1C1 = "=IFERROR(VLOOKUP((UPPER(CONCATENATE(RC[-6],""_"",(LEFT(RC[-5],1)),""_" & InputtedModuleCode & """))),'N:\EssaySubTrial\[Student List 201213.xls]Sheet1'!C1:C9,7,FALSE),"""")"
Range("G3").Select
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("G3").AutoFill Destination:=Range("G3:G" & LR), Type:=xlFillDefault
' insert Portico student department name
Range("H2").Select
ActiveCell.FormulaR1C1 = "Dept (Portico)"
Range("H3").Select
ActiveCell.FormulaR1C1 = "=IFERROR(VLOOKUP((UPPER(CONCATENATE(RC[-7],""_"",(LEFT(RC[-6],1)),""_" & InputtedModuleCode & """))),'N:\EssaySubTrial\[Student List 201213.xls]Sheet1'!C1:C9,9,FALSE),"""")"
Range("H3").Select
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("H3").AutoFill Destination:=Range("H3:H" & LR), Type:=xlFillDefault
' Format column headers and widths
Rows("2:2").Select
Selection.Font.Bold = True
Columns("G:G").EntireColumn.AutoFit
Columns("H:H").EntireColumn.AutoFit
'Sort alphabetically by surname/firstname
Range("A3").Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A3:A" & LR) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B3:B" & LR) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A2:H" & LR)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' Move SCN column from Column G to Column C
Columns("C:C").Select
Selection.Insert Shift:=xlToRight
Columns("G:G").Select
Selection.Cut Destination:=Columns("C:C")
Columns("C:C").Select
' Remove ' at ' from Date Uploaded column
Columns("F").Replace What:=" at ", Replacement:=" ", LookAt:=xlPart
' Format date and add extra date columns
Columns("F:F").Select
Selection.NumberFormat = "dd/mm/yyyy hh:mm:ss"
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("G2").Select
ActiveCell.FormulaR1C1 = "Extension Date"
Range("F2").Select
ActiveCell.FormulaR1C1 = "Essay Deadline"
Columns("F:G").Select
Selection.NumberFormat = "dd/mm/yyyy hh:mm:ss"
' Add user inputted submission date
Range("F3").Select
ActiveCell.FormulaR1C1 = CDate(InputtedSubmissionDeadline)
Range("F3").Select
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("F3").AutoFill Destination:=Range("F3:F" & LR), Type:=xlFillCopy
' Cleanup column width and add extra column
Columns("F:F").EntireColumn.AutoFit
Range("I2").Select
ActiveCell.FormulaR1C1 = "Days late"
Columns("J:J").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("J2").Select
ActiveCell.FormulaR1C1 = "Penalty (%pts)"
' Number of days late column
Range("I3").Select
ActiveCell.FormulaR1C1 = _
"=IF((RC[-1]-(IF(RC[-2]=0,RC[-3],RC[-2]))<=0), 0, (ROUNDUP(RC[-1]-(IF(RC[-2]=0,RC[-3],RC[-2])),0)))"
Range("I3").Select
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("I3").AutoFill Destination:=Range("I3:I" & LR), Type:=xlFillDefault
' Penalty %pts column
Range("J3").Select
ActiveCell.FormulaR1C1 = _
"=(IF(RC[-1]>7,100,(IF(RC[-1]>1,10,IF(RC[-1]>0,5,0)))))"
Range("J3").Select
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("J3").AutoFill Destination:=Range("J3:J" & LR), Type:=xlFillDefault
' Add marks columns
Range("M2").Select
ActiveCell.FormulaR1C1 = "1stM Grade"
Range("N2").Select
ActiveCell.FormulaR1C1 = "2ndM Grade"
Range("O2").Select
ActiveCell.FormulaR1C1 = "Final Grade"
Range("O2").Select
ActiveCell.FormulaR1C1 = "Agreed Grade"
' Add final grade colum
Range("P2").Select
ActiveCell.FormulaR1C1 = "Final Grade (after penalty)"
Range("P3").Select
ActiveCell.FormulaR1C1 = "=MAX(0,(RC[-1]-RC[-6]))"
Range("P3").Select
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("P3").AutoFill Destination:=Range("P3:P" & LR), Type:=xlFillDefault
' Add column with formatted submission deadline date that can be read by MailMerge in word
Range("Q2").Select
ActiveCell.FormulaR1C1 = "Submission Deadline (formatted)"
Range("Q3").Select
ActiveCell.FormulaR1C1 = "=TEXT(RC[-11],""dd-mmm-YYYY HH:mm:ss"")"
Range("Q3").Select
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("Q3").AutoFill Destination:=Range("Q3:Q" & LR), Type:=xlFillDefault
' Add column with formatted submission deadline date that can be read by MailMerge in word
Range("R2").Select
ActiveCell.FormulaR1C1 = "Date Uploaded (formatted)"
Range("R3").Select
ActiveCell.FormulaR1C1 = "=TEXT(RC[-10], ""dd-mmm-YYYY HH:mm:ss"")"
Range("R3").Select
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("R3").AutoFill Destination:=Range("R3:R" & LR), Type:=xlFillDefault
'Save file
ActiveWorkbook.SaveAs Filename:="N:\EssaySubTrial\" & InputtedModuleCode & " Datasheet " & _
Format(Now(), "yyyy-mm-dd HHmmss") & ".xlsx", FileFormat:=xlOpenXMLWorkbook, Password:="", _
WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
Sheets("Sheet3").Select
ActiveWindow.SelectedSheets.Delete
Sheets("Sheet2").Select
ActiveWindow.SelectedSheets.Delete
' do Mailmerge
Dim wdOutputName, wdInputName As String
wdOutputName = ThisWorkbook.Path & "\Coversheet " & Format(Date, "d mmm yyyy")
wdInputName = ThisWorkbook.Path & "\coursework-coversheet-template-merged-updated.docx"
' open the mail merge layout file
Dim wdDoc As Object
Set wdDoc = GetObject(wdInputName, "Word.document")
wdDoc.Application.Visible = True
With wdDoc.MailMerge
.MainDocumentType = wdFormLetters
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
.Execute Pause:=False
End With
' find and replace module code
wdDoc.Application.ActiveDocument.Content.Find.Execute "ANTHXXXX", ReplaceWith:=InputtedModuleCode, Replace:=wdReplaceAll
' show and save output file
wdDoc.Application.Visible = True
wdDoc.Application.ActiveDocument.SaveAs wdOutputName
' cleanup
wdDoc.Close SaveChanges:=False
Set wdDoc = Nothing
End Sub
I haven't check the remainder of the code but if your problem is merely the Find and replace at the bottom of the code then the following should do the job (setting the replacement from a string shouldn't matter):
'I'd recommend leaving all these options in
With wdDoc.Application.Selection.Find
.ClearFormatting
.Text = "ANTHXXXX"
.Replacement.Text = InputtedModuleCode
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchFuzzy = False
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
One other thing if you're interested, the code wdDoc.Application.ActiveDocument.SaveAs does exactly the same thing as wdDoc.SaveAs.