Splitting Workbook into separate workbooks including all tabs - vba

I looked at Bhaskar's code on the post located here (VBA code to split an excel file into multiple workbooks based on the contents of a column?)
and have modified it to the point where it recognizes the field I need the workbooks split on but I am getting a variable not defined error at the following section
For Each rw In UsedRange.Rows
I appreciate any help you could provide
I have included the code.
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("Source").Range("AM1") ' 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 - ***ERROR IS HERE***
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

Related

Multiple Open Workbooks combined to one sheet

I extract multiple reports daily and they all start with the word "report". They all have the same amount of columns just different amount of rows. What I have created is a sub that will loop through all open workbooks with the name "report" in the beginning and grab the data to put in consecutive order in my master workbook "Distribution"
I have the macro doing exactly what I need it to do but I am looking for guidance to make it more dynamic. The Header row I am copying every time and if a new column is added it wouldn't be captured. Same with the rows.
I am still fairly new to VBA but I think I am starting to understand more and more. Sorry for all the commented sections. Any helpful pointers would be greatly appreciated.
Private Sub CommandButton3_Click()
'Get Data button
Dim wbk As Workbook
Dim wsh As Worksheet
Dim nrow As Long
Set wsh = ActiveWorkbook.Worksheets("Data")
screen 0 'turns off calculation and screen updating
nrow = 2
For Each wbk In Workbooks
If Left(wbk.Name, 6) = "report" Then
wbk.Worksheets(1).Range("A1:Z1").Copy _ 'copies the header row
Destination:=wsh.Range("A1") 'paste data in row 1
wbk.Worksheets(1).Range("A2:Z500").Copy _ 'copy the rest of the
Destination:=wsh.Range("A" & nrow) 'paste data next available row
wbk.Close False
nrow = wsh.UsedRange.Rows.Count + 1 'Next row to paste next sheet into
End If
Next wbk
nrow = 0 ' reset next row
FilterData 'Function to filter unwanted data
screen 1 'Turn on screen updating and calculation
End Sub
Private Sub CommandButton3_Click()
'Get Data button
Dim wbk As Workbook
Dim wsh As Worksheet
Dim nrow As Long
Set wsh = ActiveWorkbook.Worksheets("Data")
screen 0
For Each wbk In Workbooks
If Left(wbk.Name, 6) = "report" Then
wbk.Worksheets(1).Range("A1:Z1").Copy _
Destination:=wsh.Range("A1")
nrow = Worksheets("Data").Cells(Rows.Count, 1).End(xlUp).Row + 1
wbk.Worksheets(1).Range("A2:Z500").Copy _
Destination:=wsh.Range("A" & nrow)
wbk.Close False
End If
Next wbk
nrow = 0
FilterData
Sheets("admin").Select
screen 1
End Sub

VBA : Run a macro FOR another workbook (not from)

I have a workbook (A) in which I have one module with one subroutine. The subroutine downloads an excel file (workbook(B)) from the internet and opens it. The problem I'm faced with is finding a way to execute a subroutine in workbook (B) from the sub in workbook (A).
To reiterate, I have my desired subroutine only in workbook (A) and wish to apply it to workbook (B) by use of the sub in workbook (A).
Note: In my code workbook (B) = Nuance Mobility JIRA.xls and the desired subroutine in workbook (B) that needs to be executed is removeColumns().
My code can be found below :
Public Sub DL()
Dim WebUrl As String
Dim x As Workbook
Dim z As Workbook
Dim nmjexcel As String
Dim xlApp As Excel.Application
' I check to see if the file exists and delete it if it does
nmjexcel = "C:\Users\" & [A2] & "\Downloads\Nuance Mobility JIRA.xls"
If Len(Dir(nmjexcel)) <> 0 Then
SetAttr nmjexcel, vbNormal
Kill nmjexcel
End If
'I open chrome and download the file from an URL
WebUrl = [J1]
Shell ("C:\Program Files (x86)\Google\Chrome\Application\chrome.exe -url " & WebUrl)
Application.Wait (Now + TimeValue("0:00:3"))
'I create a new 'hidden' excel app and open workbook (B)
Set xlApp = New Excel.Application
xlApp.Visible = False
Set x = Workbooks.Open("C:\Users\" & [A2] & "\Downloads\Nuance Mobility JIRA.xls")
' I delete some rows, a picture and some columns.
' It's here that i would like my other subroutine, removeColumns(), to take place !
With x.Sheets("general_report")
.Rows("1:3").Delete
.Shapes.Range(Array("Picture 1")).Delete
.Cells.UnMerge
.Range("A:A,D:D,E:E,F:F,H:H,I:I,J:J,K:K,L:L,M:M,N:N,O:O,P:P").Delete Shift:=xlToLeft
End With
'Then I copy whats left and paste it into workbook (A)
Set z = ThisWorkbook
Application.ScreenUpdating = False
x.Sheets("general_report").Range("A1").CurrentRegion.Copy
z.Sheets(1).Range("A13").PasteSpecial xlValues
x.Save
x.Application.CutCopyMode = False
x.Close
End Sub
My desired sub to be executed is the following
Sub removeColumns()
Dim rng As Range 'store the range you want to delete
Dim c 'total count of columns
Dim I 'an index
Dim j 'another index
Dim headName As String 'The text on the header
Dim Status As String 'This vars is just to get the code cleaner
Dim Name As String
Dim Age As String
Dim sht As Worksheet
Rows("1:3").Delete
Key = "Key"
Summary = "Summary"
Status = "Status"
Set sht = Sheets("general_report")
sht.Activate 'all the work in the sheet "Incidents"
c = Range("A1").End(xlToRight).Column
'From A1 to the left at the end, and then store the number
'of the column, that is, the last column
j = 0 'initialize the var
For I = 1 To c 'all the numbers (heres is the columns) from 1 to c
headName = Cells(1, I).Value
If (headName <> Key) And (headName <> Summary) And (headName <> Status) Then
'if the header of the column is differente of any of the options
j = j + 1 ' ini the counter
If j = 1 Then 'if is the first then
Set rng = Columns(I)
Else
Set rng = Union(rng, Columns(I))
End If
End If
Next I
rng.Delete 'then brutally erased from leaf
End Sub
Thank you very much in advance !
Further questions :
1) Is there a way to keep the downloaded excel hidden ?
I have :
Set xlApp = New Excel.Application
xlApp.Visible = False
Set x = Workbooks.Open("C:\Users\" & [A2] & "\Downloads\Nuance Mobility JIRA.xls")
But if i use x= xlApp.Workbooks.Open it gives me an error 'subscript out of range' and highlights :
Set sht = Sheets("general_report")
I tried doing
Dim xlApp as Excel.Application)
...
Set sht = xlApp.Sheets("general_report")
But it gets more errors
2) More generally, is their a way to keep the focus on my workbook (A), so that when chrome downloads the workbook (B) the chrome window doesn't pop up in front ?
The problem you are facing, occurs because you dont directly address the needed worksheet/workbook, you rather always use the Selected worksheet, which you shouldn´t. It´s unclear and can be done just as simple if directly referring.
To refer to the worbookB I added a parameter to the sub removeColumns, so you can pass the needed workbook.
In the sub then, you just need to use the reference wherever you are working with the worksheet.
So instead of just writing:
somVariable = Cells(1,1).Value 'This always refers to the 'Selected' worksheet
You have to write:
someVariable = myWorkbook.myWorksheet.Cells(1,1).Value
'or to use the parameter wb like i did in your code:
someVariable = wb.Sheets(1).Cells(1,1).Value
'Here the first sheet of this workbook will be used
'You also can use the 'With' statment here:
With wb.Sheets(1)
someVariable = .Cells(1,1).Value 'Note the dot in font of the 'Cells'
End With
So to use this knowledge in you example, you should try to alter code like following:
/////////////////////////////////////////////////////////////////////////
Set xlApp = New Excel.Application
xlApp.Visible = False
xlApp.Workbooks.Open("C:\Users\" & [A2] & "\Downloads\Nuance Mobility JIRA.xls")
Set x = xlApp.Workbooks(1)
Call removeColumns(x)
/////////////////////////////////////////////////////////////////////////
Sub removeColumns(ByVal wb As Workbok)
...
'Always when you are referring to the workbook, you have to use the reference passed as parameter
wb.Sheets("general_report").Rows("1:3").Delete
'In you code the first three rows will always be deleted from the 'Selected' sheet and not the one you are working on later, the 'general_report'
...
Set sht = wb.Sheets("general_report")
'Also don´t activate() sheet here, youst directly refer to it later
'sht.Activate 'all the work in the sheet "Incidents"
'You can directly refer t it over the variable you created, like this:
c = sht.Range("A1").End(xlToRight).Column
'From A1 to the left at the end, and then store the number
'of the column, that is, the last column
j = 0 'initialize the var
For I = 1 To c 'all the numbers (heres is the columns) from 1 to c
headName = sht.Cells(1, I).Value
If (headName <> Key) And (headName <> Summary) And (headName <> Status) Then
'if the header of the column is differente of any of the options
j = j + 1 ' ini the counter
If j = 1 Then 'if is the first then
Set rng = sht.Columns(I)
Else
Set rng = Union(rng, sht.Columns(I))
End If
End If
Next I
rng.Delete 'then brutally erased from leaf
End Sub
Hope I could help and if something is still unclear feel free to ask.

Macro that loops through drop down and creates a worksheet for each drop down selection

So I have a dashboard sheet named "Business Plans" where I have a dropdown in cell A2 that's a dropdown selection of a range called "Facilities" and all dashboard data are driven off of lookups. What I want to do is First create a new workbook than a new tab for each dropdown selection with the tab in the same format but the data pasted as values. I attempted the following code that I created to save every dropdown selection as PDF but I have been unsuccessful. Any insight on how I can get this code working will be great.
Sub Worksheet_Generator()
Dim cell As Range
Dim wsSummary As Worksheet
Dim counter As Long
Set wsSummary = Sheets("Business Plans")
For Each cell In Worksheets("dd").Range("$C3:$C75")
If cell.Value = "" Then
counter = counter + 1
Application.StatusBar = "Processing file: " & counter & "/1042"
Else
counter = counter + 1
Application.StatusBar = "Processing file: " & counter & "/1042"
With wsSummary
.Range("$A$2").Value = cell.Value
ActiveSheet.Copy After:=Worksheets(Worksheets.Count)
ActiveSheet.Copy
With ActiveSheet.UsedRange
.Value = .Value
End With
End With
End If
Next cell
Set wsSummary = Nothing
End Sub
I think you are looking for something like the below (adapted from copying-dynamic-rows-into-new-workbook-and-save-it).
Option Explicit
Sub grabber()
Dim thisWb As Workbook: Set thisWb = ThisWorkbook
Dim thisWs As Worksheet: Set thisWs = thisWb.Worksheets("dd") 'replace with relevant name
Dim newBook As Workbook
Dim newws As Worksheet
Dim pathToNewWb As String
Dim uKeys
Dim currentPath, columnWithKey, numCols, numRows, uKey, dataStartRow, columnKeyName
'nobody likes flickering screens
Application.ScreenUpdating = False
'remove any filter applied to the data
thisWs.AutoFilterMode = False
'get the path of the workbook folder
currentPath = Application.ThisWorkbook.Path
'Set the stage
'###Hardcode###
columnKeyName = "Facility" 'name of the column with the facility values
dataStartRow = 4 'this is a pure guess, correct as relevenat. Use the header row index
pathToNewWb = currentPath & "/Business Plans.xlsx" ' where to put the new excel, if you want a saveas prompt you should google "Application.FileDialog(msoFileDialogSaveAs)"
uKeys = Range("Facilities").Value
'###Hardcode End###
columnWithKey = thisWs.Range(dataStartRow & ":" & dataStartRow).Find(what:=columnKeyName, LookIn:=xlValues).Column
numCols = thisWs.UsedRange.Columns.Count
'extract the index of the last used row in the worksheet
numRows = thisWs.UsedRange.Rows.Count
'create the new workbook
Set newBook = Workbooks.Add
'loop the facilities, and do the work
For Each uKey In uKeys
'Filter the keys column for a unique key
thisWs.Range(thisWs.Cells(dataStartRow, 1), thisWs.Cells(numRows, numCols)).AutoFilter field:=columnWithKey, Criteria1:=uKey
'copy the sheet
thisWs.UsedRange.Copy
'Create a new ws for the facility, and paste as values
Set newws = newBook.Worksheets.Add
With newws
.Name = uKey 'I assume the name of the facility is the relevant sheet name
.Range("A1").PasteSpecial xlPasteValues
End With
'remove autofilter (paranoid parrot)
thisWs.AutoFilterMode = False
Next uKey
'save the new workbook
newBook.SaveAs pathToNewWb
newBook.Close
End Sub
EDIT:
As I have not seen your data, I would not be surprised if it requires some revision.
First I try to "frame" the range of the worksheet "dd" that contains the data (the ###Hardcode### bit), define the path for the output, and identify the column that can be filtered for the values corresponding to the named range "Facilities".
I retrieve the values of the named range "Facilities" (into uKeys), and create the output workbook (newBook). Then we go through each value (uKey) from the uKeys in the for loop. Within the loop, I apply an autofilter for the uKey. The filtration is followed by creation of a sheet (newWs) in newBook, and a copy paste of the filtered worksheet "dd" into newWs. we then turn off the autofilter, and the worksheet "dd" is returned to its unfiltered state.
At the end we save newBook to the desired location, and close it.

Merge Multiple Workbooks that have multiple worksheets using VBA

I keep having this issue of VBA either not having an object for the new sheet I want to merge, or having the subscript out of range issue come up. None of the things I tried ended up working.
Private Sub MergeButton_Click()
Dim filename As Variant
Dim wb As Workbook
Dim s As Sheet1
Dim thisSheet As Sheet1
Dim lastUsedRow As Range
Dim j As Integer
On Error GoTo ErrMsg
Application.ScreenUpdating = False
Set thisSheet = ThisWorkbook.ActiveSheet
MsgBox "Reached method"
'j is for the sheet number which needs to be created in 2,3,5,12,16
For Each Sheet In ActiveWorkbook.Sheets
For i = 0 To FilesListBox.ListCount - 1
filename = FilesListBox.List(i, 0)
'Open the spreadsheet in ReadOnly mode
Set wb = Application.Workbooks.Open(filename, ReadOnly:=True)
'Copy the used range (i.e. cells with data) from the opened spreadsheet
If FirstRowHeadersCheckBox.Value And i > 0 Then 'Only include headers from the first spreadsheet
Dim mr As Integer
mr = wb.ActiveSheet.UsedRange.Rows.Count
wb.ActiveSheet.UsedRange.Offset(3, 0).Resize(mr - 3).Copy
Else
wb.ActiveSheet.UsedRange.Copy
End If
'thisSheet = ThisWorkbook.Worksheets(SheetCurr)
'Paste after the last used cell in the master spreadsheet
If Application.Version < "12.0" Then 'Excel 2007 introduced more rows
Set lastUsedRow = thisSheet.Range("A65536").End(xlUp)
Else
Set lastUsedRow = thisSheet.Range("A1048576").End(xlUp)
End If
'Only offset by 1 if there are current rows with data in them
If thisSheet.UsedRange.Rows.Count > 1 Or Application.CountA(thisSheet.Rows(1)) Then
Set lastUsedRow = lastUsedRow.Offset(1, 0)
End If
lastUsedRow.PasteSpecial
Application.CutCopyMode = False
Next i
This is where I try to add an extra loop that copies the next sheet (which is Sheet12) but it comes up with the Subscript our of range error.
Sheets("Sheet3").Activate
Sheet.Copy After:=ThisWorkbook.Sheets
Next Sheet
It will then move to the next sheet to perform the loop again.
ThisWorkbook.Save
Set wb = Nothing
#If Mac Then
'Do nothing. Closing workbooks fails on Mac for some reason
#Else
'Close the workbooks except this one
Dim file As String
For i = 0 To FilesListBox.ListCount - 1
file = FilesListBox.List(i, 0)
file = Right(file, Len(file) - InStrRev(file, Application.PathSeparator, , 1))
Workbooks(file).Close SaveChanges:=False
Next i
#End If
Application.ScreenUpdating = True
Unload Me
ErrMsg:
If Err.Number <> 0 Then
MsgBox "There was an error. Please try again. [" & Err.Description & "]"
End If
End Sub
Any help an this would be great
Your source code is very confusing and I believe you're stumbling because the ActiveWorkbook and ActiveSheet change each time you open a new workbook. It's also not clear why you're copying/merging the data from each worksheet in every opened workbook and then copying Sheet3. You will help yourself by more clearly defining what and where your data is and how you're moving it around.
As an example (that may not solve your problem, because your problem is not clear), look at the code below to see how you can keep the sources and destinations straight within your loops. Modify this example as much as you need in order to match your exact situation.
Sub Merge()
'--- assumes that each sheet in your destination workbook matches a sheet
' in each of the source workbooks, then copies the data from each source
' sheet and merges/appends that source data to the bottom of each
' destination sheet
Dim destWB As Workbook
Dim srcWB As Workbook
Dim destSH As Worksheet
Dim srcSH As Worksheet
Dim srcRange As Range
Dim i As Long
Application.ScreenUpdating = False
Set destWB = ThisWorkbook
For i = 0 To FileListBox.ListCount - 1
Set srcWB = Workbooks.Open(CStr(FileListBox(i, 0)), ReadOnly:=True)
For Each destSH In destWB.Sheets
Set srcSH = srcWB.Sheets(destSH.Name) 'target the same named worksheet
lastdestrow = destSH.Range("A").End(xlUp)
srcSH.UsedRange.Copy destSH.Range(Cells(lastdestrow, 1))
Next destSH
srcWB.Close
Next i
Application.ScreenUpdating = True
End Sub

Report Split - Excel VBA Doesn't Copy all Rows and runs Indefinetly

I have written the following Excel VBA Macro, its job is to split a report based on CountryCode. It creates a new workbook, copies the relevant rows to a new workbook, saves the workbook by the CountryCode.
The problem I encouter is missing rows and for one worksheet, it continues running on empty rows? - Basically it doesn't stop and copies over empty rows.
Has cell formatting anything to do with it?
There is another Macro that runs only once which creates the workbooks first. It is only run once on the first worksheet, never again.
Sub RUN2_ReportSplitterOptimized()
Application.DisplayAlerts = False
Application.EnableEvents = False
' Current Workbook
Dim cW As Workbook
Dim cWL As String
Dim cWN As String
Set cW = ThisWorkbook
cWL = cW.Path
cWN = cW.Name
' Current Worksheet
Dim cS As Worksheet
Set cS = ActiveSheet
Do Until IsEmpty(ActiveCell)
' Current Active Cell
Dim aC As Range
Set aC = ActiveCell
' Split input string
Dim CC As String
CC = splitCC(aC.Text)
Dim wb As Workbook
Dim ws As Worksheet
On Error Resume Next
Set wb = Workbooks(CC & ".xlsx")
If Err.Number <> 0 Then
Set wb = Workbooks.Open(cWL & "\" & CC & ".xlsx")
' Create the worksheet
Set ws = wb.Sheets.Add
' Copy the row to the worksheet
ws.Rows(1).Value = cS.Rows(1).Value
ws.Rows(2).Value = aC.EntireRow.Value
With ws
.Name = cS.Name
End With
Else
wb.Activate
On Error Resume Next
Set ws = wb.Sheets(cS.Name)
If Err.Number <> 0 Then
Set ws = wb.Sheets.Add
' Copy the row to the worksheet
ws.Rows(1).Value = cS.Rows(1).Value
ws.Rows(2).Value = aC.EntireRow.Value
With ws
.Name = cS.Name
End With
Else
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
ws.Rows(LastRow + 1).Value = aC.EntireRow.Value
End If
End If
wb.Save
cW.Activate
aC.Offset(1, 0).Select
Loop
Dim wbk As Workbook
For Each wbk In Workbooks
If Len(wbk.Name) = 7 Then
wbk.Close
End If
Next
End Sub
Function splitCC(countrycode As String) As String
If Len(countrycode) < 3 Then
splitCC = countrycode
Else
splitCC = Mid(countrycode, InStr(countrycode, "(") + 1, 2)
End If
End Function
Solved it.
I have used filters as recommended by #sous2817
Instead of running couple of hours - it does the entire job within 2 minutes :D
Thanks for your help
Problem has been solved here: Excel VBA AutoFilter adds empty rows