Workbook saves code delete tabs before save - excel

Sorry for the oddly worded question. I have code (below) that creates new sheets based on column data. After the sheets are created VBA copies and pastes every row from the master sheet into the category sheet. I just want excel to save the .csv file and close. It closes but only keeps the last sheet. Is this due to it being a .csv file? If I manually Save As and convert to .xlsx then the columns remain. But I tried adding VBA code to do the same thing and it just saved an empty .xlsx file. I'm not sure what to do...
Sub Loading_Summary_Breakout()
'Prevents Clipboard Pop-up from appearing.
Application.DisplayAlerts = False
'Prevents screen flicker and makes the macro run faster.
Application.ScreenUpdating = False
'Opens Loading Summary workbook.
Workbooks.Open Filename:=Environ("USERPROFILE") & "\Dropbox (Gotham Enterprise)\Operations Management\#MASTER SCHEDULE\Shop Schedule V4\Loading Summary.csv"
Workbooks("Loading Summary.csv").Activate
Call DeleteRowsSpecialChartrs
Dim cell As Range, v
Dim SheetName As String, wb As Workbook, ws As Worksheet
Set ws = ActiveSheet
Set wb = ws.Parent
'Creates new worksheet/tab for every unique value in Column B (Customer Code Column)
For Each cell In ws.Range(ws.Range("B2"), ws.Range("B" & Rows.Count).End(xlUp)).Cells
v = cell.Value
If Len(v) > 0 Then cell.EntireRow.Range("A1:O1").Copy _
GetSheet(v, wb).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Next
Call DeleteDuplicates
ActiveWorkbook.Save
Application.ScreenUpdating = True
End Sub
'Return a named sheet in wb (or create if doesn't exist)
Private Function GetSheet(ByVal SheetName As String, wb As Workbook)
Dim ws As Worksheet
On Error Resume Next
Set ws = wb.Worksheets(SheetName)
On Error GoTo 0
If ws Is Nothing Then
Set ws = wb.Worksheets.Add(after:=wb.Sheets(wb.Sheets.Count))
ws.Name = SheetName
End If
Set GetSheet = ws
End Function
Public Sub DeleteRowsSpecialChartrs()
Dim rng As Range
Dim pos As Integer
Set rng = ActiveSheet.Range("B:B")
For i = rng.Cells.Count To 1 Step -1
pos = InStr(LCase(rng.Item(i).Value), LCase("/"))
If pos > 0 Then
rng.Item(i).EntireRow.Delete
End If
Next i
End Sub
Public Sub DeleteDuplicates()
Dim ws As Worksheet
Dim wkbk1 As Workbook
Dim w As Long
Set wkbk1 = Workbooks("Loading Summary.csv")
wkbk1.Activate
With wkbk1
For w = 1 To .Worksheets.Count
With Worksheets(w)
.Range("A:O").RemoveDuplicates Columns:=1, Header:=xlYes
End With
Next w
End With
End Sub

I wonder what the text in this message means...
I's the text you see when you 'Save As'/'CSV'.

Related

Create new workbook with named tabs

Ok what i want to do is make a macro that makes a new workbook with 5 tabs from a list in my excel.
I got the new workbook part, I got the (named) tabs part, but i'm stuck at the combination due to lack of knowledge.
Sub CreateForm()
Workbooks.Add
Dim xRg As Excel.Range
Dim wSh As Excel.Worksheet
Dim wBk As Excel.Workbook
Set wSh = ActiveSheet
Set wBk = ActiveWorkbook
Application.ScreenUpdating = False
For Each xRg In wSh.Range("I6:I12")
With wBk
.Sheets.Add After:=.Sheets(.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xRg.Value
If Err.Number = 1004 Then
Debug.Print xRg.Value & " already used as a sheet name"
End If
On Error GoTo 0
End With
Next xRg
End Sub
It almost works, it makes a new workbook with extra tabs, but it is one too many(due to with creation it having one already), and they are not named.
Bonus Question: It would be awesome if I also could copy a tab(named "Results") from this workbook to the end of the new workbook, but this is just extra.
You can use this code.
I read the new worksheet names to an array.
The number of sheets in a new workbook can vary - as the user can configure this. Therefore I first delete all sheets except of the first one, then add then new sheets - and in the end delete the first one (which is left from the first deletion round)
Sub createNewWorkbookWithSheets()
Dim arrNewNames As Variant
arrNewNames = Application.Transpose(ActiveSheet.Range("I6:I12").Value)
Dim wbNew As Workbook
Set wbNew = Application.Workbooks.Add
Dim i As Long, ws As Worksheet
With wbNew
'delete all but the first worksheet - one has to be left
Application.DisplayAlerts = False
For i = 2 To .Worksheets.Count
.Worksheets(i).Delete
Next
Application.DisplayAlerts = True
'add new worksheet
For i = LBound(arrNewNames) To UBound(arrNewNames)
Set ws = .Worksheets.Add(, .Worksheets(.Worksheets.Count))
ws.Name = arrNewNames(i)
Next
'delete first ws
Application.DisplayAlerts = False
.Worksheets(1).Delete ' the left one from the first deletion round
Application.DisplayAlerts = True
End With
'copy result sheet from this workbook
Set ws = ThisWorkbook.Worksheets("Result")
ws.Copy , wbNew.Worksheets(wbNew.Worksheets.Count)
End Sub
You are adding a workbook, once that workbook has been created it becomes the active workbook.
If you want to use activeworkbook and activesheet to set the sheet name range, you could to do this before adding the new workbook.
Once you have run the code, you can delete the first sheet.
I think in this sample, you don't need activeworkbook because you are using activesheet
BTW I6:I12 would be 7 items not 5.
It need to be in chronological order.
Something like this.
Sub CreateForm()
Dim xRg As Range,rng as range
Dim wSh As Worksheet
Dim wBk As Workbook,bk as workbook
Set wBk = ActiveWorkbook
Set wSh = ActiveSheet
Set rng= wsh.range("I6:I12")
set bk = workbooks.add
For Each xRg In rng
With bk
.Sheets.Add After:=.Sheets(.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xRg.Value
If Err.Number = 1004 Then
Debug.Print xRg.Value & " already used as a sheet name"
End If
On Error GoTo 0
End With
Next xRg
End Sub
(a) wSh is set to the active sheet of the new created workbook and that is empty, therefore xRg.Value is always empty. This explains why your sheets are not renamed. Set it to the sheet holding the sheet names, eg
Set wSh = ThisWorkbook.Sheets(1)
(b) When you create a new Workbook, you will have (depending on your Excel settings) at least 1 worksheet. In your loop, you create a new sheet for every iteration, leaving the original sheets untouched. This explains why you have one sheet more than you expect.
Dim newSheetCount As Long
For Each xRg In wSh.Range("I6:I12")
With wBk
newSheetCount = newSheetCount + 1
' Add a new sheet if needed.
if .Sheets.Count < newSheetCount Then .Sheets.Add After:=.Sheets(.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xRg.Value
If Err.Number = 1004 Then
Debug.Print xRg.Value & " already used as a sheet name"
End If
On Error GoTo 0
End With
Next xRg
(c) Copying a sheet is easy, just use the Worksheet.Copy method:
ThisWorkbork.Sheets("Result").Copy After:=.Sheets(.Sheets.Count)

How do I copy and paste entire row only when cell equals sheet/tab name?

I need help with one aspect of my VBA code. I have a Master worksheet that houses data on all of my customers. I currently have code that looks at Column B (Customer Name Column) and creates new worksheets/tabs for each unique customer. I then want to cut and paste every row from my Master worksheet into individual respective worksheets based on the customer name. I've included a picture of my Master worksheet. I've also included the code I'm currently working with is below, it creates the new tabs but won't copy and paste.
Sub CreateWSandCopyPaste()
Application.ScreenUpdating = False
Dim cell As Range
Dim thisSheetName As String
AWS = ActiveSheet.Name
'Creates new worksheet/tab for every unique value in Column B (Customer Code Column)
For Each cell In Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
If (cell.Value <> "") Then
If (IsSheetExist(cell.Value) = False) Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = cell.Value
End If
End If
Next
'Copy and paste value A:U if the value in column B matches the tab name
Dim ws As Worksheet
For Each ws In Sheets
If ActiveSheet.Range("B2").Value = ws.Name Then
ActiveSheet.Range("A:U").CurrentRegion.Copy Destination:=ws.Range("A:U" & Rows.Count).End(x1Up)
End If
Next
Application.ScreenUpdating = True
End Sub
Private Function IsSheetExist(ByVal newSheetName As String)
Dim ws As Worksheet
For Each ws In Worksheets
If (ws.Name = newSheetName) Then
IsSheetExist = True
Exit Function
End If
Next
' ---
IsSheetExist = False
End Function
Master Worksheet - Customer Column
You can do it like this:
Sub CreateWSandCopyPaste()
Dim cell As Range, v
Dim thisSheetName As String, wb As Workbook, ws As Worksheet
Application.ScreenUpdating = False
Set ws = ActiveSheet
Set wb = ws.Parent
'Creates new worksheet/tab for every unique value in Column B (Customer Code Column)
For Each cell In ws.Range(ws.Range("B2"), ws.Range("B" & Rows.Count).End(xlUp)).Cells
v = cell.Value
If Len(v) > 0 Then cell.EntireRow.Range("A1:U1").Copy _
GetSheet(v, wb).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Next
Application.ScreenUpdating = True
End Sub
'Return a named sheet in wb (or create if doesn't exist)
Private Function GetSheet(ByVal SheetName As String, wb As Workbook)
Dim ws As Worksheet
On Error Resume Next
Set ws = wb.Worksheets(SheetName)
On Error GoTo 0
If ws Is Nothing Then
Set ws = wb.Worksheets.Add(after:=wb.Sheets(wb.Sheets.Count))
ws.Name = SheetName
End If
Set GetSheet = ws
End Function

Copy two worksheets into different workbook replacing current data

I modified code from Copy worksheet into different workbook replacing current data.
If I deselect range or I have selected different cell than A1, code falls into 1004 error.
Sub TG_update()
Dim wb1 As Workbook, wb2 As Workbook, ws1Format As Worksheet, ws2Format As Worksheet, ws3Format As Worksheet, ws4Format As Worksheet
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set wb1 = ThisWorkbook
Set wb2 = Workbooks.Open("[add your path.xlsx]")
Set ws1Format = wb1.Sheets("SheetA1")
Set ws2Format = wb2.Sheets("SheetB1")
Set ws3Format = wb1.Sheets("SheetA2")
Set ws4Format = wb2.Sheets("SheetB2")
'' Copy the cells of the "Format" worksheet.
ws2Format.Cells.Copy
'' Paste cells to the sheet "Format".
wb1.Sheets("SheetA1").Paste
ws4Format.Cells.Copy
wb1.Sheets("SheetB1").Paste
wb2.Close False 'remove false if you want to be asked if the workbook shall be saved.
wb1.Sheets("Store").Activate
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Date successfully updated"
End Sub
Please try this code. Instead of copying and pasting millions of blank cells this code copies the worksheet from the source and pastes it to the workbook with the code. If the action is successful the old sheet is deleted. The final report alerts about errors if sheets weren't found.
Sub TG_update()
' 016
Dim Wb As Workbook ' ThisWorkbook
Dim WbS As Workbook ' Source
Dim Ffn As String ' Full FileName
Dim Ws As Worksheet
Dim TabName() As String
Dim i As Integer ' TabName index
Dim n As Integer ' tab counter
Set Wb = ThisWorkbook
' specify the workbook to be copied from: Full path and name
Ffn = "F:\AWK PC\Drive E (Archive)\PVT Archive\Class 1\1-2018 (Jan 2020)\TXL 180719 Z Distance.xlsm"
' enumerate the sheet names in CSV format (sheets must exist in Wb)
TabName = Split("SheetA1,SheetB1", ",")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Set WbS = Workbooks.Open(Ffn)
For i = 0 To UBound(TabName)
On Error Resume Next ' suppress error if worksheet isn't found
WbS.Worksheets(TabName(i)).Copy After:=Wb.Worksheets(Wb.Worksheets.Count)
If Err.Number = 0 Then
n = n + 1
End If
Next i
WbS.Close SaveChanges:=False
On Error GoTo 0
For i = 0 To UBound(TabName)
For Each Ws In Wb.Worksheets
If InStr(Ws.Name, TabName(i) & " (") = 1 Then
Wb.Worksheets(TabName(i)).Delete
Ws.Name = TabName(i)
End If
Next Ws
Next i
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
MsgBox n & " of " & i & " worksheets were successfully updated.", _
vbInformation, "Action report"
End Sub
Creative names like Wb1, Wb2, Ws1, Ws2, SheetA1, SheetA2 represent the punishment imaginative programmers inflict on those who come after them to correct their hastily concocted code. Give your VBA project a better reputation by bestowing names on your two worksheets that permit their identification.

Compare and update master worksheets if they exist in another workbook?

I have a master workbook, which houses a group of 15 worksheets that house data for summary pivot tables and whatnot. Every week this master workbook gets updated with a daily report that has those 15 worksheets, but also around 20 other ones. I am just trying to get a script together to identify if they exist, and if so, to move that daily data to the master workbooks worksheet (only move data if daily wb worksheet exists in master workbook).
Here is a very general shell of what I'm trying to achieve, but I'm not well versed in determining the logic if a sheet exists, so my blnFound variable is obviously misplaced. I hope this shows a rough outline of what I'm trying to achieve. Any help is greatly appreciated!
Option Explicit
Sub Update_New_Data()
Const BasePath As String = "C:\\User\Data..."
Dim wbMaster As Workbook: Set wbMaster = ThisWorkbook
Dim wbNewData As Workbook: Set wbNewData = Workbooks.Open(BasePath & "\03.01.20.xlsx")
Dim wsMaster As Sheet
Dim blnFound As Boolean
'places all sheet names into array
With wbNewData
Dim varWsName As Variant
Dim i As Long
Dim ws As Worksheet
ReDim varWsName(1 To wbNewData.Worksheets.Count - 2)
For Each ws In wbNewData.Worksheets
Select Case ws.Name
Case "Inputs", "Data --->>>"
Case Else
i = i + 1
varWsName(i) = ws.Name
End Select
Next
End With
'if wbNewData sheet name is found in wbMaster
'then locate it and place wbNewData data into that sheet
With wbMaster
For Each wsMaster In wbMaster.Sheets
With wsMaster
If .Name = varWsName(i) Then
blnFound = True
wbNewData(Worksheets(i)).UsedRange.Copy Destination:=wbMaster(Worksheets(i)).Range("A1")
Else: blnFound = False
End If
End With
Next
End With
End Sub
To check if something exists you can use a Dictionary Object
Option Explicit
Sub Update_New_Data()
Const BasePath As String = "C:\\User\Data..."
Dim wbMaster As Workbook, wbNewData As Workbook
Set wbMaster = ThisWorkbook
Set wbNewData = Workbooks.Open(BasePath & "\03.01.20.xlsx", , False) ' read only
Dim ws As Worksheet, sKey As String, rng As Range, msg As String
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
'places all master sheet names into dictionary
For Each ws In wbMaster.Sheets
If ws.Name = "inputs" Or ws.Name = "Data --->>>" Then
' skip
Else
dict.Add CStr(ws.Name), ws.Index
Debug.Print "Added to dict", ws.Index, ws.Name
End If
Next
' if wbNewData sheet name is found in wbMaster
' then locate it and place wbNewData data into that sheet
For Each ws In wbNewData.Sheets
sKey = CStr(ws.Name)
If dict.exists(sKey) Then
' clear master
wbMaster.Sheets(dict(sKey)).cells.clear
Set rng = ws.UsedRange
rng.Copy wbMaster.Sheets(dict(sKey)).Range("A1")
msg = msg & vbCr & ws.Name
Else
Debug.Print "Not found in master", ws.Index, ws.Name
End If
Next
wbNewData.Close
' result
If Len(msg) > 0 Then
MsgBox "Sheets copied were " & msg, vbInformation
Else
MsgBox "No sheets copied", vbExclamation
End If
End Sub

Excel - Copy each row into new workbook but keep column names - Macro

I found this great Macro that copies each of my rows in my data frame separately into a new sheet, but keeps the first row with the column names as well:
Sub abc_01()
Dim WS As Worksheet, newWS As Worksheet
Dim X As String
Application.ScreenUpdating = False
Set WS = Sheets("Sheet1")
On Error Resume Next
X = InputBox("number of names 1,2,", , "9")
For i = 1 To X
Set newWS = Worksheets.Add(after:=Worksheets(Worksheets.Count))
WS.Range("A1:G1").Copy Destination:=newWS.Range("A1")
WS.Range(WS.Cells(i + 1, "A"), WS.Cells(i + 1, "G")).Copy
newWS.Range("A2").PasteSpecial xlValues
Next i
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
I tried now to copy it into a new workbook rather than a new sheet, but the new workbook stays empty when I run it. Also, I haven't saved the new workbooks yet as a new filename (ideally a specific cell value if possible?)
Sub abc_02()
Dim thisWB As String
Dim newWB As String
thisWB = ActiveWorkbook.Name
Dim X As String
Application.ScreenUpdating = False
Set WS = Sheets("Sheet1")
On Error Resume Next
X = InputBox("number of names 1,2,", , "9")
For i = 1 To X
Workbooks.Add
ActiveWorkbook.SaveAs supName
newWB = ActiveWorkbook.Name
Windows(thisWB).Activate
Sheets("Sheet1").Select
Range("A1:G1").Copy
Windows(newWB).Activate
Sheets("Sheet1").Select
ActiveSheet.Range("A1").Select
ActiveSheet.Range("A1").Paste
Windows(thisWB).Activate
Sheets("Sheet1").Select
Range(Sheet1.Cells(i + 1, "A"), Sheet1.Cells(i + 1, "G")).Copy
Windows(newWB).Activate
Sheets("Sheet1").Select
Range("A2").PasteSpecial xlValues
Next i
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
I am a VBA noob so any help much appreciated!
In the original code, you have
Dim WS As Worksheet, newWS As Worksheet
Dim X As String
Dim WS as Worksheet and newWS as Worksheet tells Excel "WS and newWS will be worksheets."
Later in the code, these are set respectively, WS as Sheet1 in the active workbook, and newWS as a new worksheet within the active workbook.
Changing
Dim thisWB As String
Dim newWB As String
to
Dim thisWB As Workbook
Dim newWB As Workbook
should fix your issue.
You should be dimming thisWB and newWB as Workbooks, not strings.
Excel will be looking for a string of text instead of Workbooks.
Also - try looking on ExcelForum.com VBA section; I learnt a lot of what I know from there.
Hope that helps

Resources