I have an excel sheet with defined names I would like to copy it with VBA by copying also the defined names. How can I do?
My current macro to copy the sheet:
Sub myMacro()
Const BASE_NAME As String = "MySheet"
Dim sheet_name As String
Dim i As Integer
Dim num_text As String
Dim new_num As Integer
Dim max_num As Integer
Dim new_sheet As Worksheet
' Find the largest number in a sheet name after the
' base name.
max_num = 0
For i = 1 To Sheets.Count
sheet_name = Sheets(i).Name
If Left$(sheet_name, Len(BASE_NAME)) = BASE_NAME _
Then
num_text = Mid$(sheet_name, Len(BASE_NAME) + 1)
new_num = Val(num_text)
If new_num > max_num Then max_num = new_num
End If
Next i
' Make a new sheet with a new number.
Set new_sheet = Sheets.Add(after:=Sheets(Sheets.Count))
new_sheet.Name = BASE_NAME & Format$(max_num + 1)
new_sheet.Select
Sheets("MySheet_template").Range("A1:DQ1109").Copy
Destination:=Sheets(new_sheet.Name).Range("A1")
End Sub
Try this - a slightly different approach
Sub myMacro()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim sh As Shape, strtSh As Worksheet
Set strtSh = ActiveSheet
Sheets("MySheet_template").Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = "MySheet" & Sheets.Count - 1
For Each sh In ActiveSheet.Shapes
sh.Delete
Next sh
strtSh.Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Related
I've got a code that generates a workbook by copying and moving selected worksheets into a new workbook.
The first page of this new workbook is a summary page. On this i want to pull data from the subsequent worksheets by using the range.value method.
However can I use this when referencing the worksheet location for example
Dim wb As Workbook, wbAll As Workbook
Dim ws As Worksheet
Set wbAll = Workbooks.Add
On Error Resume Next
For t = 1 To 100
Set wb = Workbooks("Book" & t)
For Each ws In wb.Sheets
ws.Move after:=wbAll.Sheets(Sheets.Count)
Next
Next
Workbooks("Book" & t).Activate
ActiveWorkbook.Sheets("Sheet1").Select
'compile worksheets into list
Dim wss As Worksheet
Dim x As Integer
On Error Resume Next
x = 17
Sheets("Sheet1").Range("c17:E46").ClearContents
For Each wss In ActiveWorkbook.Worksheets
If wss.Name <> "Sheet1" Then
Sheets("Sheet1").Cells(x, 3) = wss.Name
x = x + 1
End If
Next wss
'COMPILE COSTS
ActiveWorkbook.Sheet1.Range("C17").Value = ActiveWorkbook.Worksheet(2).Range("Q118").Value
ActiveWorkbook.Sheet1.Range("C18").Value = ActiveWorkbook.Worksheet(3).Range("Q118").Value
.
.
ActiveWorkbook.Sheet1.Range("C45").Value = ActiveWorkbook.Worksheet(30).Range("Q118").Value
ActiveWorkbook.Sheet1.Range("C46").Value = ActiveWorkbook.Worksheet(31).Range("Q118").Value
'Compile WBS
ActiveWorkbook.Sheet1.Range("D17").Value = ActiveWorkbook.Worksheet(2).Range("D10").Value
ActiveWorkbook.Sheet1.Range("D18").Value = ActiveWorkbook.Worksheet(3).Range("D10").Value
.
.
ActiveWorkbook.Sheet1.Range("D45").Value = ActiveWorkbook.Worksheet(30).Range("D10").Value
ActiveWorkbook.Sheet1.Range("D46").Value = ActiveWorkbook.Worksheet(31).Range("D10").Value
'Week Number name
ActiveWorkbook.Sheet1.Range("C10").Value = ActiveWorkbook.Worksheet(2).Range("D4").Value
'Supplier Name
ActiveWorkbook.Sheet1.Range("C12").Value = ActiveWorkbook.Worksheet(2).Range("D5").Value
This however gives me an error message of object defined error
This may help:
EDIT: updated to show using links instead of copying the values from the sheet.
Sub Tester()
Dim wb As Workbook, wbAll As Workbook
Dim ws As Worksheet
Dim wss As Worksheet
Dim x As Integer, wsSummary, t As Long
Set wbAll = Workbooks.Add
For t = 1 To 100
Set wb = Nothing
On Error Resume Next 'ignore any error
Set wb = Workbooks("Book" & t)
On Error GoTo 0 'cancel OERN as soon as possible
If Not wb Is Nothing Then
For Each ws In wb.Sheets
ws.Move after:=wbAll.Sheets(wbAll.Sheets.Count)
Next
End If
Next
'Workbooks("Book" & t).Activate 'not sure what this is for?
'ActiveWorkbook.Sheets("Sheet1").Select
'compile worksheets into list
x = 17
Set wsSummary = wbAll.Sheets("Sheet1")
wsSummary.Range("C17:E46").ClearContents
For Each wss In wbAll.Worksheets
If wss.Name <> wsSummary.Name Then
With wsSummary.Rows(x)
'.Cells(3).Value = wss.Name
InsertLink .Cells(5), wss.Range("A1"), "=SheetName({1})"
'.Cells(4).Value = wss.Range("Q118").Value
InsertLink .Cells(4), wss.Range("Q118") 'create a link
'.Cells(5).Value = wss.Range("D10").Value
InsertLink .Cells(5), wss.Range("D10")
'etc etc
End With
x = x + 1
End If
Next wss
End Sub
'UDF to return the sheet name
Function SheetName(c As Range)
Application.Volatile
SheetName = c.Parent.Name
End Function
'Insert a worksheet formula into a cell (rngDest), where the precedents
' are either a single cell/range or an array of cells/ranges (SourceRange)
' sTemplate is an optional string template for the formula
' eg. "=SUM({1},{2})" where {1} and {2} are ranges in SourceRange
' Empty template defaults to "={1}"
'Useage:
' InsertLink sht1.Range("A1"), Array(sht1.Range("B1"), sht1.Range("C1")), "=SUM({1},{2})"
Sub InsertLink(rngDest As Range, SourceRange As Variant, Optional sTemplate As String)
Dim i As Long, sAddress As String, arrTmp As Variant
If sTemplate = "" Then sTemplate = "={1}" 'default is a simple linking formula
'got a single range, or an array of ranges?
If TypeName(SourceRange) = "Range" Then
arrTmp = Array(SourceRange) 'make an array from the single range
Else
arrTmp = SourceRange 'use as-is
End If
'loop over the input range(s) and build the formula
For i = LBound(arrTmp) To UBound(arrTmp)
sAddress = ""
If rngDest.Parent.Name <> arrTmp(i).Parent.Name Then
sAddress = "'" & arrTmp(i).Parent.Name & "'!"
End If
sAddress = sAddress & arrTmp(i).Address(False, False)
sTemplate = Replace(sTemplate, "{" & CStr(i + 1) & "}", sAddress)
Next i
rngDest.Formula = sTemplate 'assign the formula
End Sub
I am trying to create a macro that can be used to summarise data provided by users on a weekly basis. I have written several Subroutines that combined do what I want, but I'm now looking to be able to run the VBA code once on all workbooks in a folder and save me from opening each one and then running the macro.
To give context the idea is to sum daily activity and place this on a newly created worksheet in the workbook which I call "Weekly Totals", the idea being that I'll copy the data from "Weekly Totals" to a single workbook at a later point.
Sub DoEverything()
Dim ws As Worksheet
For Each ws In Worksheets
ws.Activate
SumRowsValues
SumColumnsValues
Next ws
AddTotalSheet
CopyFromWorksheets
ListSheetNames
GetFileName
RemoveTextBeforeUnderscore
StringToDate
End Sub
I have created a Personal.xlsb so that I can access the Subroutine above and I have another macro that opens every workbook within a designated folder, but what can I add to this Subroutine that would make it apply to any number of workbooks that I open or that are in this designated folder?
Edit:
I shall include the code so the question is not wasting people's time unnecessarily.
Sub SumRowsValues()
Dim i As Long
For i = 4 To 44
If Application.WorksheetFunction.Sum(Range(Cells(i, 3), Cells(i, 10))) <> 0 Then
Cells(i, 11) = 15
End If
Next i
End Sub
Sub SumColumnsValues()
Dim i As Long
For i = 3 To 11
Cells(45, i) = Application.WorksheetFunction.Sum(Range(Cells(4, i), Cells(44, i)))
Next i
End Sub
Sub AddTotalSheet()
Sheets.Add(Before:=Sheets("Mon")).Name = "Weekly Totals"
End Sub
Sub CopyFromWorksheets()
Worksheets("Weekly Totals").Range("A1").Value = "Date"
Worksheets("Weekly Totals").Range("B1").Value = "Person"
Worksheets("Weekly Totals").Range("C1").Value = "Day"
Worksheets("Mon").Range("C3:K3").Copy Worksheets("Weekly Totals").Range("D1")
Worksheets("Mon").Range("C45:K45").Copy Worksheets("Weekly Totals").Range("D2")
Worksheets("Tue").Range("C45:K45").Copy Worksheets("Weekly Totals").Range("D3")
Worksheets("Wed").Range("C45:K45").Copy Worksheets("Weekly Totals").Range("D4")
Worksheets("Thu").Range("C45:K45").Copy Worksheets("Weekly Totals").Range("D5")
Worksheets("Fri").Range("C45:K45").Copy Worksheets("Weekly Totals").Range("D6")
End Sub
Sub ListSheetNames()
Dim ws As Worksheet
Sheets("Weekly Totals").Activate
ActiveSheet.Cells(2, 3).Select
For Each ws In Worksheets
If ws.Name = "Weekly Totals" Then
Else
ActiveCell = ws.Name
ActiveCell.Offset(1, 0).Select
End If
Next
End Sub
Sub GetFileName()
Dim strFileFullName, DateText, NameText, strDuplicateFileName As String
strFileFullName = ActiveWorkbook.Name
strDuplicateFileName = strFileFullName
DateText = Split(strFileFullName, "_")
NameText = Split(strDuplicateFileName, ".")
Worksheets("Weekly Totals").Range("A2").Value = DateText
Worksheets("Weekly Totals").Range("B2").Value = NameText
End Sub
Sub RemoveTextBeforeUnderscore()
Dim i As Long '
Dim rng As Range
Dim cell As Range
Set rng = Worksheets("Weekly Totals").Range("B2")
For i = 1 To 5 '
For Each cell In rng
cell(i, 1).Value = Right(cell.Value, Len(cell.Value) + 1 - InStr(cell.Value, "_") - 1)
Next cell
Next i
End Sub
Sub StringToDate()
Dim InitialValue As Long
Dim DateAsString As String
Dim FinalDate As Date
InitialValue = Worksheets("Weekly Totals").Range("A2").Value
DateAsString = CStr(InitialValue)
FinalDate = DateSerial(CInt(Left(DateAsString, 4)), CInt(Mid(DateAsString, 5, 2)), CInt(Right(DateAsString, 2)))
Range("A2").Value = FinalDate
Range("A3").Value = FinalDate + 1
Range("A4").Value = FinalDate + 2
Range("A5").Value = FinalDate + 3
Range("A6").Value = FinalDate + 4
Columns("A").AutoFit
End Sub
Not I am sure the most efficient or elegant, but it does work to this point. The code for opening all workbooks in a folder is:
Sub OpenAllFilesDirectory()
Dim Folder As String, FileName As String
Folder = "pathway..."
FileName = Dir(Folder & "\*.xlsx")
Do
Workbooks.Open Folder & "\" & FileName
FileName = Dir
Loop Until FileName = ""
End Sub
All the files will having the naming convention of "YYYYMMDD_Name.xlsx", e.g. 20211128_JSmith
The table on worksheet looks like this:
etc.
The output looks like this:
etc.
This is partially tested since we have no data to test for the SumRowsValues, SumColumnsValues and CopyFromWorksheets but it should work as I did not change much from it other than changing the range reference away from ActiveWorkbook and Activesheet.
I have tried to change as little as possible from the original code as this answer is only focused on how to connect OpenAllFilesDirectory to DoEverything. There are many things that can be streamlined and improve on.
Option Explicit
Const TOTAL_WSNAME As String = "Weekly Totals"
Sub OpenAllFilesDirectory()
Dim Folder As String, FileName As String
Folder = "pathway..."
FileName = Dir(Folder & "\*.xlsx")
Do
Dim currentWB As Workbook
Set currentWB = Workbooks.Open(Folder & "\" & FileName)
DoEverything currentWB
FileName = Dir
Loop Until FileName = ""
End Sub
Sub DoEverything(argWB As Workbook)
Dim ws As Worksheet
For Each ws In argWB.Worksheets
SumRowsValues ws
SumColumnsValues ws
Next ws
Dim totalWS As Worksheet
Set totalWS = AddTotalSheet(argWB)
CopyFromWorksheets argWB
ListSheetNames argWB
GetFileName totalWS
RemoveTextBeforeUnderscore totalWS
StringToDate totalWS
End Sub
Sub SumRowsValues(argWS As Worksheet)
Dim i As Long
For i = 4 To 44
If Application.WorksheetFunction.Sum(argWS.Range(argWS.Cells(i, 3), argWS.Cells(i, 10))) <> 0 Then
argWS.Cells(i, 11) = 15
End If
Next i
End Sub
Sub SumColumnsValues(argWS As Worksheet)
Dim i As Long
For i = 3 To 11
argWS.Cells(45, i) = Application.WorksheetFunction.Sum(argWS.Range(argWS.Cells(4, i), argWS.Cells(44, i)))
Next i
End Sub
Function AddTotalSheet(argWB As Workbook) As Worksheet
Dim totalWS As Worksheet
Set totalWS = argWB.Sheets.Add(Before:=argWB.Sheets("Mon"))
totalWS.Name = TOTAL_WSNAME
Set AddTotalSheet = totalWS
End Function
Sub CopyFromWorksheets(argWB As Workbook)
Dim totalWS As Worksheet
Set totalWS = argWB.Worksheets(TOTAL_WSNAME)
totalWS.Range("A1").Value = "Date"
totalWS.Range("B1").Value = "Person"
totalWS.Range("C1").Value = "Day"
argWB.Worksheets("Mon").Range("C3:K3").Copy totalWS.Range("D1")
argWB.Worksheets("Mon").Range("C45:K45").Copy totalWS.Range("D2")
argWB.Worksheets("Tue").Range("C45:K45").Copy totalWS.Range("D3")
argWB.Worksheets("Wed").Range("C45:K45").Copy totalWS.Range("D4")
argWB.Worksheets("Thu").Range("C45:K45").Copy totalWS.Range("D5")
argWB.Worksheets("Fri").Range("C45:K45").Copy totalWS.Range("D6")
End Sub
Sub ListSheetNames(argWB As Workbook)
Dim insertCell As Range
Set insertCell = argWB.Worksheets(TOTAL_WSNAME).Range("C2")
Dim ws As Worksheet
For Each ws In argWB.Worksheets
If ws.Name <> TOTAL_WSNAME Then
insertCell.Value = ws.Name
Set insertCell = insertCell.Offset(1)
End If
Next
End Sub
Sub GetFileName(argWS As Worksheet)
Dim strFileFullName As String
Dim DateText As String
Dim NameText As String
strFileFullName = argWS.Parent.Name
DateText = Split(strFileFullName, "_")(0)
NameText = Split(strFileFullName, ".")(0)
argWS.Range("A2").Value = DateText
argWS.Range("B2").Value = NameText
End Sub
Sub RemoveTextBeforeUnderscore(argWS As Worksheet)
Dim i As Long
Dim rng As Range
Dim cell As Range
Set rng = argWS.Range("B2")
For i = 1 To 5 '
For Each cell In rng
cell(i, 1).Value = Right(cell.Value, Len(cell.Value) + 1 - InStr(cell.Value, "_") - 1)
Next cell
Next i
End Sub
Sub StringToDate(argWS As Worksheet)
Dim InitialValue As Long
Dim DateAsString As String
Dim FinalDate As Date
InitialValue = argWS.Range("A2").Value
DateAsString = CStr(InitialValue)
FinalDate = DateSerial(CInt(Left(DateAsString, 4)), CInt(Mid(DateAsString, 5, 2)), CInt(Right(DateAsString, 2)))
argWS.Range("A2").Value = FinalDate
argWS.Range("A3").Value = FinalDate + 1
argWS.Range("A4").Value = FinalDate + 2
argWS.Range("A5").Value = FinalDate + 3
argWS.Range("A6").Value = FinalDate + 4
argWS.Columns("A").AutoFit
End Sub
So, I have one excel workbook containing around 80 sheets, the sheets are named as Input, Input(1), input, INPUT, INPUT(2) and Output, Output(1), Output(2), output, OUTPUT and so on, you get the idea... I want to create a macro which creates two mastersheets in the Workbook named "MASTERSHEET INPUT" and "MASTERSHEET Output". The macro should copy all the data from any sheet having any variation of input in its sheet name and paste it one into the MASTERSHEET INPUT and the same goes for the sheets named output which will be pasted into MASTERSHEET OUTPUT. I'm relatively new to VBA and I'd really appreciate it if someone could help me out.
Thanks in advance!
This is the code I was using previously
Sub CombineData()
Dim I As Long
Dim xRg As Range
On Error Resume Next
Worksheets.Add Sheets(1)
ActiveSheet.Name = "MasterSheet"
For I = 2 To Sheets.Count
Set xRg = Sheets(1).UsedRange
If I > 2 Then
Set xRg = Sheets(1).Cells(xRg.Rows.Count + 1, 1)
End If
Sheets(I).Activate
ActiveSheet.UsedRange.Copy xRg
Next
End Sub
But this merges all the sheets in the workbook into one without checking the sheet name.
I tried using this one next but this just pastes the first Output sheet into both mastersheets and then ends:
Sub CombineData()
Dim I As Long
Dim xRg As Range
Dim xWs As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Worksheets.Add Sheets(1)
ActiveSheet.Name = "MasterSheet Output"
For I = 2 To Sheets.Count
Set xRg = Sheets(1).UsedRange
If I > 2 Then
Set xRg = Sheets(1).Cells(xRg.Rows.Count + 1, 1)
End If
For Each xWs In Application.ActiveWorkbook.Worksheets
If xWs.Name = "OUTPUT*" Or xWs.Name = "output*" Or xWs.Name = "Output*" Then
Sheets(I).Activate
ActiveSheet.UsedRange.Copy xRg
End If
Next
Next
On Error Resume Next
Worksheets.Add Sheets(1)
ActiveSheet.Name = "MasterSheet Input"
For I = 3 To Sheets.Count
Set xRg = Sheets(1).UsedRange
If I > 2 Then
Set xRg = Sheets(1).Cells(xRg.Rows.Count + 1, 1)
End If
For Each xWs In Application.ActiveWorkbook.Worksheets
If xWs.Name = "INPUT*" Or xWs.Name = "input*" Or xWs.Name = "Input*" Then
Sheets(I).Activate
ActiveSheet.UsedRange.Copy xRg
End If
Next
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Call DeleteAllSheetsExceptMaster
End Sub
I also tried using this but this does absolutely nothing:
Sub CombineData()
Dim I As Long
Dim xrg As Range
Dim counter As Long
Dim xWs1 As Worksheet
Dim xWs2 As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
For counter = 1 To 2
Worksheets.Add Sheets(1)
If counter = 1 Then
ActiveSheet.Name = "MasterSheet Input"
Set xWs1 = ActiveSheet
End If
If counter = 2 Then
ActiveSheet.Name = "MasterSheet Output"
Set xWs2 = ActiveSheet
End If
Next counter
For I = 2 To Sheets.count
Set xrg = Sheets(1).UsedRange
If I > 2 Then
Set xrg = Sheets(1).Cells(xrg.Rows.count + 1, 1)
End If
Sheets(I).Activate
If Sheets(I).Name = "OUTPUT*" Or Sheets(I).Name = "output*" Or Sheets(I).Name = "Output*" Then
ActiveSheet.UsedRange.Copy xWs2
End If
If Sheets(I).Name = "INPUT*" Or Sheets(I).Name = "input*" Or Sheets(I).Name = "Input*" Then
ActiveSheet.UsedRange.Copy xWs1
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Create Master Sheets
The following will delete each of the master worksheets if they exist and then create new ones. Then it will copy the data from the current region starting in A1 of the defined source worksheets to the appropriate master worksheets (read OP's requirements).
The Code
Option Explicit
Sub createMasterSheets()
' Define constants incl. the Names Arrays and the workbook.
Const srcFirst As String = "A1"
Const tgtFirst As String = "A1"
Dim srcNames As Variant
srcNames = Array("iNpUt", "oUtPuT") ' Case does not matter.
Dim tgtNames As Variant
tgtNames = Array("MasterIn", "MasterOut")
Dim wb As Workbook
Set wb = ThisWorkbook
' Define lower and upper subscripts of the 1D arrays:
' srcNames, tgtNames, Dicts
Dim sFirst As Long
sFirst = LBound(srcNames)
Dim sLast As Long
sLast = UBound(srcNames)
' Turn off screen updating.
Application.ScreenUpdating = False
' Add Target Worksheets.
Dim ws As Worksheet
Dim n As Long
For n = sLast To sFirst Step -1
On Error Resume Next
Set ws = wb.Sheets(tgtNames(n))
On Error GoTo 0
If Not ws Is Nothing Then
Application.DisplayAlerts = False
wb.Sheets(tgtNames(n)).Delete
Application.DisplayAlerts = True
End If
wb.Worksheets.Add Before:=wb.Sheets(1)
ActiveSheet.Name = tgtNames(n)
Next n
' Define Dictionaries Array and populate it with Dictionaries.
' The Dictionaries will hold the Data Arrays.
Dim Dicts As Variant
ReDim Dicts(sFirst To sLast)
Dim dict As Object
For n = sFirst To sLast
Set dict = CreateObject("Scripting.Dictionary")
Set Dicts(n) = dict
Next n
' Declare variables.
Dim wsName As String ' Current Worksheet Name
Dim rng As Range ' Current Source Range, Current Target Cell Range
Dim m As Long ' Subscript of Current Data Array in Current Dictionary
' of Dictionaries Array
' Write values from Source Ranges to Data Arrays.
For Each ws In wb.Worksheets
wsName = ws.Name
For n = sFirst To sLast
If InStr(1, wsName, srcNames(n), vbTextCompare) = 1 Then
' Define Source Range. You might need to do this in another way.
Set rng = ws.Range(srcFirst).CurrentRegion
m = m + 1
Dicts(n)(m) = rng.Value ' This will fail later if one cell only.
Exit For
End If
Next n
Next ws
' Declare variables
Dim Key As Variant ' Current Key in Current Dictionary
' of Dictionaries Array.
' Write values from Data Arrays to Target Ranges.
For n = sFirst To sLast
Set rng = wb.Worksheets(tgtNames(n)).Range(tgtFirst)
Set ws = wb.Worksheets(tgtNames(n))
For Each Key In Dicts(n).Keys
rng.Resize(UBound(Dicts(n)(Key), 1), _
UBound(Dicts(n)(Key), 2)).Value = Dicts(n)(Key)
Set rng = rng.Offset(UBound(Dicts(n)(Key), 1))
Next Key
Next n
' Turn on screen updating.
Application.ScreenUpdating = True
' Inform user.
MsgBox "Sheets created, data transferred.", vbInformation, "Success"
End Sub
See if this works for you.
Edit: fixed case sensitivity.
Sub CopyFromWorksheets()
Dim wrk As Workbook 'Workbook object - Always good to work with object variables
Dim sht As Worksheet 'Object for handling worksheets in loop
Dim trg As Worksheet 'Input Master
Dim trg2 As Worksheet 'Output Master
Dim rng As Range 'Range object
Set wrk = ActiveWorkbook 'Working in active workbook
'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
'Rename the new worksheet
trg.Name = "Input Master"
'Add new worksheet as the last worksheet
Set trg2 = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
'Rename the new worksheet
trg2.Name = "Output Master"
'We can start loop
For Each sht In wrk.Worksheets
'If worksheet in loop is the last one, stop execution (it is Master worksheet)
If sht.Index = wrk.Worksheets.Count - 1 Then
Exit For
ElseIf LCase(sht.Name) Like "*" & "input" & "*" Then
Set rng = sht.Range(sht.Cells(1, 1), sht.Cells(65536, 1).End(xlUp))
'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
ElseIf LCase(sht.Name) Like "*" & "output" & "*" Then
Set rng = sht.Range(sht.Cells(1, 1), sht.Cells(65536, 1).End(xlUp))
'Put data into the Master worksheet
trg2.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
End If
Next sht
'Fit the columns in Master worksheet
trg.Columns.AutoFit
trg.Rows(1).Delete
trg.Columns.AutoFit
trg2.Rows(1).Delete
End Sub
I cannot find the named range or reference that is invalid, according to Excel. I checked my named ranges, including ranges within charts. The excel file contains a macro that creates a report that works fine when launched within the file itself. However, if I call that function from another workbook to run the report that is when I get the error message of invalid references. When going through the reports created both directly and indirectly they seem identical. Setting Application.DisplayAlerts = False does not work.
I tried using the code below from from Allen Wyatt to go through all reference and none refer to outside sheets nor contain any errors.
Sub CheckReferences()
' Check for possible missing or erroneous links in
' formulas and list possible errors in a summary sheet
Dim iSh As Integer
Dim sShName As String
Dim sht As Worksheet
Dim c, sChar As String
Dim rng As Range
Dim i As Integer, j As Integer
Dim wks As Worksheet
Dim sChr As String, addr As String
Dim sFormula As String, scVal As String
Dim lNewRow As Long
Dim vHeaders
vHeaders = Array("Sheet Name", "Cell", "Cell Value", "Formula")
'check if 'Summary' worksheet is in workbook
'and if so, delete it
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With
For i = 1 To Worksheets.Count
If Worksheets(i).Name = "Summary" Then
Worksheets(i).Delete
End If
Next i
iSh = Worksheets.Count
'create a new summary sheet
Sheets.Add After:=Sheets(iSh)
Sheets(Sheets.Count).Name = "Summary"
With Sheets("Summary")
Range("A1:D1") = vHeaders
End With
lNewRow = 2
' this will not work if the sheet is protected,
' assume that sheet should not be changed; so ignore it
On Error Resume Next
For i = 1 To iSh
sShName = Worksheets(i).Name
Application.Goto Sheets(sShName).Cells(1, 1)
Set rng = Cells.SpecialCells(xlCellTypeFormulas, 23)
For Each c In rng
addr = c.Address
sFormula = c.Formula
scVal = c.Text
For j = 1 To Len(c.Formula)
sChr = Mid(c.Formula, j, 1)
If sChr = "[" Or sChr = "!" Or _
IsError(c) Then
'write values to summary sheet
With Sheets("Summary")
.Cells(lNewRow, 1) = sShName
.Cells(lNewRow, 2) = addr
.Cells(lNewRow, 3) = scVal
.Cells(lNewRow, 4) = "'" & sFormula
End With
lNewRow = lNewRow + 1
Exit For
End If
Next j
Next c
Next i
' housekeeping
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
End With
' tidy up
Sheets("Summary").Select
Columns("A:D").EntireColumn.AutoFit
Range("A1:D1").Font.Bold = True
Range("A2").Select
End Sub
I'm not experienced with VBA, but I think it's the only way for this to work.
I need to send a report to each sales team, but don't want to send them the information of other sales team. There are multiple sheets per workbook with different reports which all have a sales team column.
I would like all the sheets to be filtered by sales team, and create a new workbook for each team.
I appreciate any help.
I got this solution.
Just send me an email if you need this solution.
At first I got this format:
I create the following macro code
Option Explicit
Dim MainWorkBook As Workbook
Dim NewWorkBook As Workbook
Sub ExportWorksheet()
Dim Pointer As Long
Set MainWorkBook = ActiveWorkbook
Range("E2").Value = MainWorkBook.Sheets.Count
Application.ScreenUpdating = False 'enhance the performance
For Pointer = 2 To MainWorkBook.Sheets.Count
Set NewWorkBook = Workbooks.Add
MainWorkBook.Sheets(Pointer).Copy After:=NewWorkBook.Sheets(1)
Application.DisplayAlerts = False
NewWorkBook.Sheets(1).Delete
Application.DisplayAlerts = True
With NewWorkBook
.SaveAs Filename:="C:\Users\lengkgan\Desktop\Testing\" & MainWorkBook.Sheets(Pointer).Name & ".xls" 'you may change to yours
End With
NewWorkBook.Close SaveChanges:=True
Next Pointer
Application.ScreenUpdating = True
Range("D5").Value = "Export Completed"
End Sub
Following is the output
I have written a VBA(Macro) program which will work based on Input data. All you need to do is, provide input data in a column in another sheet. Macro will read the data and filter Master Sheet based on each row then it Generate new excel sheet based on find data.
enter Option Explicit
Dim personRows As Range 'Stores all of the rows found
'Split data into separate columns baed on the names defined in
'a RepList on the 'Names' sheet.
Sub SplitSalesData()
Dim wb As Workbook
Dim p As Range
Dim counter2 As Integer
Dim i As Integer
counter2 = 0
i = 0
Application.ScreenUpdating = False
' in my case i am generating new excel based on every 8 reacords from begining. You can simplyfy this logic based on your need.
For Each p In Sheets("Names").Range("RepList") ' Give the name of your input sheet and column
If i = 0 Then ' We are starting, so generate new excel in memeory.
Workbooks.Add
Set wb = ActiveWorkbook
ThisWorkbook.Activate
End If
WritePersonToWorkbook wb, p.Value
i = i + 1 ' Increment the counter reach time
If i = 8 Then ' As my need is after processing every 8 uniqe record just save the excel sheet and reset the processing
counter2 = counter2 + 1
wb.SaveAs ThisWorkbook.Path & "\salesdata_" & CStr(counter2) ' save the data at current directory location.
wb.Close
Set personRows = Nothing ' Once the process has completed for curent excelsheet, set the personRows as NULL
i = 0
End If
Next p
Application.ScreenUpdating = True
Set wb = Nothing
End Sub
'Writes all the data rows belonging to a RepList
Sub WritePersonToWorkbook(ByVal SalesWB As Workbook, _
ByVal Person As String)
Dim rw As Range
Dim firstRW As Range
For Each rw In UsedRange.Rows
If Not Not firstRW Is Nothing And Not IsNull(rw) Then
Set firstRW = rw ' WE want to add first row in each excel sheet.
End If
If Person = rw.Cells(1, 5) Then ' My filter is working based on "FeederID"
If personRows Is Nothing Then
Set personRows = firstRW
Set personRows = Union(personRows, rw)
Else
Set personRows = Union(personRows, rw)
End If
End If
Next rw
personRows.Copy SalesWB.Sheets(1).Cells(1, 1) ' Adding data in Excel sheet.
End Sub
please find below code
Sub SplitSheetDataIntoMultipleWorkbooksBasedOnSpecificColumn()
Dim objWorksheet As Excel.Worksheet
Dim nLastRow, nRow, nNextRow As Integer
Dim strColumnValue As String
Dim objDictionary As Object
Dim varColumnValues As Variant
Dim varColumnValue As Variant
Dim objExcelWorkbook As Excel.Workbook
Dim objSheet As Excel.Worksheet
Dim icol As Long
Dim l As Long
Dim headercol As Long
Dim stroutputfolder As String
stroutputfolder = "D:\Ba"
'dim str
icol = 1
headercol = 3
Set objWorksheet = ActiveSheet
nLastRow = objWorksheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row
Set objDictionary = CreateObject("Scripting.Dictionary")
For nRow = headercol + 1 To nLastRow
'Get the specific Column
'Here my instance is "B" column
'You can change it to your case
strColumnValue = objWorksheet.Cells(nRow, icol).Value
If objDictionary.Exists(strColumnValue) = False Then
objDictionary.Add strColumnValue, 1
End If
Next
varColumnValues = objDictionary.Keys
For i = LBound(varColumnValues) To UBound(varColumnValues)
varColumnValue = varColumnValues(i)
'MsgBox (varColumnValues(i))
If Dir(stroutputfolder, vbDirectory) = vbNullString Then MkDir stroutputfolder
If CStr(varColumnValue) <> "" Then
objWorksheet.UsedRange.Offset(headercol - 1, 0).AutoFilter Field:=icol, Criteria1:=CStr(varColumnValue)
Set objExcelWorkbook = Excel.Application.Workbooks.Add
Set objSheet = objExcelWorkbook.Sheets(1)
objSheet.Name = objWorksheet.Name
objWorksheet.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=[A1]
'strFilename = strOutputFolder & "\" & strItem
ActiveWorkbook.SaveAs Filename:=stroutputfolder & "\" & CStr(varColumnValue) & ".xlsb", FileFormat:=50
ActiveWorkbook.Close savechanges:=False
l = l + 1
End If
Next
objWorksheet.ShowAllData
MsgBox (l & " files splitted")
End Sub