Extract specific columns into multiple .CSVs, error in code - excel

I have an excel file where each column has varying products codes, descriptions, unit of measure, and 5 different prices (one for each distributor) in this order.
Workbook as it is:
I need to make 5 distinct .csv files, named after each distributor, each with code, discount (normally 0), one of the prices, MU and description, in this order.
What one of the CSVs should look like:
I can move columns around alright, the issues is that I can't seem to find a way to save the CSVs.
The code that I have (not mine) stops as it seems to be "unable to access the .csv" as it tries to save it.
Sub FornitoriToCSV()
Const FLDR = "C:\Users\HER-XV\Desktop" 'where to save files
Dim rng As Range, wb As Workbook, i As Long, rws As Long
Set rng = ActiveSheet.Range("A1").CurrentRegion 'data table
rws = rng.Rows.Count 'how many rows of data?
For i = 4 To rng.Columns.Count 'loop for each client column (starting at col4)
Set wb = Workbooks.Add 'add workbook
'copy data to workbook
With wb.Sheets(1)
.Range("A1").Resize(rws).Value = rng.Columns(1).Value
.Range("B1").Value = "Discount"
.Range("B2").Resize(rws - 1).Value = 0
.Range("C1").Resize(rws).Value = rng.Columns(i).Value 'client data
.Range("D1").Resize(rws).Value = rng.Columns(3).Value
.Range("E1").Resize(rws).Value = rng.Columns(2).Value
End With
'save the file using the client name
wb.SaveAs Filename:=FLDR & rng.Cells(1, i).Value & ".csv", _
FileFormat:=xlCSVUTF8, CreateBackup:=False
wb.Close False
Next i
End Sub
Any help would be much appreciated!

Related

Iteratively break out a data file to a template file and save as a new file for every 5,000 rows

I am trying to break out a data file by 5,000 rows due to limitation with a tool. I have a template file that has multiple sheets (I only have to update data on the first sheet titled 'Service Template', but I need all tabs present on the newly created files). The tool requires the template file to be used so I have to use that file instead of copying the data to a completely new file. I am also attempting to do this on a Mac, but can use virtual machine if absolutely necessary.
The data file and the template file both start on row 2 as both files have headers.
I have the below code that I have been trying to build out but it is still not working and I am stuck.
Data file sheet = 'Sheet1' and Template File Sheet = 'Service Template'
Sub test()
Dim lastRow As Long, myRow As Long, myBook As Workbook
ActiveSheet.Name = "Sheet1"
lastRow = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For myRow = 1 To lastRow Step 5000
Set myBook = Workbooks.Open("/Users/Downloads/Test/TemplateFile.xlsx")
ThisWorkbook.Sheets("Sheet1").Rows(myRow & ":" & myRow + 4999).EntireRow.Copy myBook.Sheets("Sheet1").Range("A2")
Application.DisplayAlerts = False
myBook.SaveAs Filename:="\Users\Downloads\Test\" & myBook.Name
Application.DisplayAlerts = False
myBook.Close
Next myRow
End Sub
I am looking to transfer 5000 rows (starting row2) from the data file to the template file (starting row2) save as a new file and then keep doing the same process until all of the rows are complete.
Try something like this:
Sub test()
Const BLOCK_SIZE As Long = 5000
Dim wsSrc As Worksheet, myBook As Workbook, rngCopy As Range
Set wsSrc = ActiveSheet 'or some other specific sheet
Set rngCopy = wsSrc.Rows(2).Resize(BLOCK_SIZE)
Do While Application.CountA(rngCopy) > 0 'loop while range has content
With Workbooks.Open("/Users/Downloads/Test/TemplateFile.xlsx")
rngCopy.Copy .Worksheets("Sheet1").Range("A2")
.SaveAs "\Users\Downloads\Test\" & "R" & rngCopy.Row & "_" & .Name
.Close SaveChanges:=True
End With
Set rngCopy = rngCopy.Offset(BLOCK_SIZE) 'next block down
Loop
End Sub

Find column headers by name and select all data below headers from multiple workbooks and paste the data one below other in master file in excel VBA

I have 5 different workbooks in a particular folder, Each workbook contains only 1 sheet in it.
Each workbook has same format and has about 145 headers on row 12.
This headers has some data below it, please note the data in each workbooks are different and has missing data too so not sure about last row data.
In Master file, i have mentioned 30 headers in row 3 which are needed.
I need a VBA macro which should look for headers from master file and copy the data from 1st file and paste it in master. Once the data is copied from 1st file it should copy the data from 2nd, 3rd, 4th and 5th file and paste one below another in master file.
Thanks
Please, test the next code:
Sub CopyInMaster()
Dim wb As Workbook, mWb As Workbook, mWbPath As String, shMWb As Worksheet, ws As Worksheet
Dim folderPath As String, fileName As String, arrHead, lastERM As Long, lastrWS As Long, arrCopy, i As Long, j As Long
folderPath = ThisWorkbook.path & "\TestImport\" 'use here the folder path where the workbooks to import data exist
'please, take care of the ending"\"
mWbPath = folderPath & "Master.xlsx" 'use here your Master workbook full name
'check if the master workbook is open. If not, open it
For Each wb In Workbooks
If wb.fullName = mWbPath Then Set mWb = wb: Exit For
Next
If mWb Is Nothing Then
Set mWb = Workbooks.Open(mWbPath)
End If
Set shMWb = mWb.Sheets(1) 'if the sheet to be updated in Master wb is not the first one, please adapt the code using its name
'put master headers in an array:
arrHead = shMWb.Range("A1", shMWb.cells(1, shMWb.Columns.count).End(xlToLeft)).value
'iterate between all workbooks to be used in the necessary folder:
fileName = Dir(folderPath & "*.xls*")
Do While fileName <> ""
If Not fileName = mWb.Name Then 'if the master workbook is not in the same folder, this lines can be eliminated (If - End If)
Set wb = Workbooks.Open(folderPath & fileName)
Set ws = wb.Sheets(1)
'copy each mathing column data:
For i = 1 To UBound(arrHead, 2)
For j = 1 To ws.cells(12, ws.Columns.count).End(xlToLeft).Column
If arrHead(1, i) = ws.cells(12, j).value Then
lastrWS = ws.cells(ws.rows.count, j).End(xlUp).row 'last row
lastERM = shMWb.cells(shMWb.rows.count, i).End(xlUp).row + 1 'first empty row
arrCopy = ws.Range(ws.cells(13, j), ws.cells(lastrWS, j)).value 'put the range to be copied in an array (to be faster)
shMWb.cells(lastERM, i).Resize(UBound(arrCopy), UBound(arrCopy, 2)).value = arrCopy 'drop the array content
End If
Next
Next i
wb.Close False 'close the workbook without saving it
End If
fileName = Dir()
Loop
End Sub
Please, take care to correctly adapt the necessary paths and 'Master' workbook full name!
It is good to learn, besides the above code, that we here do not offer free coding services. We (usually) only help people understanding their coding problems and learn. So, you should show us what you tried by your own and better explain what is to be done. Please, understand that I made an exception!
It is also good to know that when placing a question it is at least polite to frequently check it and answer the clarification questions, if any.
After testing it, I would like to receive some feedback. I asked about clarifications and I only assumed that this is what you like doing. If not, please accurately describe what you need against what the code returns.

Copy non adjacent data cells into one workbook

this is the code that i am currently using right now, but its not enough to meet my objectives and i am stuck on how to continue....
So this code will copy the specified data from many other excel workbook in the form of xlsx into a main excel workbook and before that it will scan through the folder which contains all the different data files and the main file(all files supposed to be transfered here in a table form) e.g. Test3.xlsx,Test4.xlsx,Test.xlxs and Main.xlsm in the folder of ScanFiles. so everytime a new files comes into the folder, it will automatically update the main workbook by opening the data workbooks then copy the required data and paste it on the main workbook upon clicking a button.
Sub ScanFiles()
Dim myFile As String, path As String
Dim erow As Long, col As Long
path = "c:\Scanfiles\"
myFile = Dir(path & "*.xlsx")
Application.ScreenUpdating = False
Do While myFile <> ""
Workbooks.Open (path & myFile)
Windows(myFile).Activate
Set copyrange = Sheets("sheet1").Range("A18,B18,C18,D18,A19,B19,C19,D19")
Windows("master-wbk.xlsm").Activate
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
col = 1
For Each cel In copyrange
cel.Copy
Cells(erow, col).PasteSpecial xlPasteValues
col = col + 1
Next
Windows(myFile).Close savechanges:=False
myFile = Dir()
Loop
Range("A:E").EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
Objectives: 1st:orignal type of file is in "file" not xlsx, so hope to find a way to open the file in xlsx format automatically before start of copying data.
2nd: requires 3 types of specified data e.g. name,surname(both of them are in fixed position always in A18 to D18 and A19 to D19 , 3rd one is to find the date, however the date is almost always in different positions in the data sheet, so i hope to add on a part to the code that makes it search for something like "ended 20190808" it will always start with ended but will always be in diff rows or even columns. i also need to arrange the data according to the date from newest(top) to oldest(bottom) and state the month of the date in words instead of numbers e.g. june
Deeply Appreciate any form of help but if possible the small section of code that can add on to my coding will make it a lot easier because im tasked to do this in a very limited amount of time
Thank you!!!
Here's some code that does similar things to what you describe. The animated .gif shows it working by stepping through the code. First the 2 data (.xlsx) files are shown so you have an idea of their content. Each is located in the same folder as the main workbook and has data in column A. Then as we step through the code each file is opened, its data manipulated (row 3 is deleted) and transferred into adjacent columns of the main workbook. The code is not limited to .xlsx files and will work with text files as well, as long as ext is defined.
Hopefully, once you understand how this works you can modify it to apply it to your case.
Option Explicit
Sub CombineFiles()
Dim theDir As String, numFiles As Integer
Dim sh As Worksheet, wk As Workbook, newSheet As Worksheet
Dim newColumn As Range, r As Range, s As String
Const ext = ".xlsx"
Err.Clear
theDir = ThisWorkbook.Path
Set newSheet = ThisWorkbook.Sheets.Add
newSheet.Name = "Combined"
Set newColumn = newSheet.Range("A1")
'Loop through all files in directory
s = Dir(theDir & "\*" & ext)
While s <> ""
numFiles = numFiles + 1
On Error Resume Next
Set wk = Workbooks.Open(theDir & "\" & s)
Set sh = ActiveSheet
sh.Rows(3).Delete Shift:=xlUp
Set r = Range("A1")
Range(r, r.End(xlDown)).Copy
newSheet.Activate
newColumn.Offset(0, numFiles) = wk.Name
newColumn.Offset(1, numFiles).Select
newSheet.Paste
Application.DisplayAlerts = False
wk.Close False
Application.DisplayAlerts = True
s = Dir()
Wend
MsgBox (numFiles & " files were processed.")
End Sub
For copy/paste of pictures see examples on this or this page. To find the last cell containing data in a column see this page; note that one example involves using the .find command. More generally, to learn how to use .find in vba, use the macro recorder and then adjust the resulting code.

Copy columns to new workbook and save as csv

I'm trying to:
Copy data (columns A and B) from one workbook (data.xlsx).
Paste into a new workbook (as values).
Save as CSV with a filename taken from column A in a third workbook (URLs.xlsx).
Process to repeat, taking the same data (which is randomised every time it is pasted) from data.xlsx and pasted into a new CSV - there are 200 rows in URLs.xlsx and so we should end up with 200 files.
I've read lots of topics, here are two I found:
Excel VBA Copy a Range into a New Workbook
https://www.excelcampus.com/vba/copy-paste-another-workbook/
What I've tried
Copying code and replacing the relevant components from various different articles across the web. Some of them work, but when I add the missing bits, I run into errors I don't understand.
Well here is an example avoiding copy pasting in new workbooks:
Expected input like:
Data.xlsx range A1:B200 with RANDBETWEEN() function:
URLs.xlsx range A1:A200 with some URL like so:
Run this code (will take approximately 1 second on my machine, tested with timer):
Dim wbData As Workbook, WBurls As Workbook
Dim CSVFileDir As String, CSVVal As String
Dim A As Long, X As Long, Y As Long, Z As Long
Option Explicit
Sub Transfer2CSV()
Set wbData = Workbooks("data.xlsx") 'Make sure it is open upon running macro
Set WBurls = Workbooks("URLs.xlsx") 'Make sure it is open upon running macro
For X = 1 To 200 'Looping through the 200 rows of WBurls
CSVFileDir = "C:\YourDrive\" & WBurls.Sheets(1).Cells(X, 1).Value & ".csv"
CSVVal = ""
A = FreeFile
Open CSVFileDir For Output As #A
With wbData.Sheets(1).Range("A1:B200") ' or whichever range you using here
.Calculate 'Randomize your range again
For Y = 1 To 200 'or however many rows you have in column A and B.
For Z = 1 To 2
CSVVal = CSVVal & .Cells(Y, Z).Value & ","
Next Z
Print #A, Left(CSVVal, Len(CSVVal) - 2)
CSVVal = ""
Next Y
End With
Close #A
Next X
End Sub
Output:
With each file looking like:
This should work. Make sure your data and URLS workbooks are open.
Sub Macro1()
Dim wsData As Worksheet, wsUrl As Worksheet, wbNew as Workbook
Dim CSVDir as String, rngU As Range
Set wsData = Workbooks("data.xlsx").Worksheets(1)
Set wsUrl = Workbooks("URLs.xlsx").Worksheets(1)
Set rngU = wsUrl.Range("A1", wsUrl.Range("A" & wsUrl.Rows.Count).End(xlUp))
CSVDir = "C:\Users\thomas.mcerlean\Desktop\Work\" 'you gave this as your dir
Set wbNew = Workbooks.Add
For Each cell In rngU
wsData.Range("A1", wsData.Range("B" & wsData.Rows.Count).End(xlUp)).Copy Destination:= wbNew.Worksheets(1).Range("A1")
wbNew.SaveAs Filename:= CSVDir & cell.Value & ".csv", FileFormat:=xlCSV
Next cell
wbNew.Close SaveChanges:=False
End Sub

Copying base data sheet along with selected sheets from source workbook to new workbook

I am looking at building a master workbook which receives a monthly dump of data for all Cost Centres which will then populate a large number of worksheets within the workbook, and which then need to be split off and sent out to service heads. A service head will receive a selection of worksheets based on the first 4 characters of the sheet name (although this may change in due course).
eg 1234x, 1234y, 5678a, 5678b will produce two new workbooks named 1234 and 5678 with two sheets in each.
I have cobbled some code from various forum to create a macro that will work through a hard coded array defining the service head 4 character codes and create a series of new workbooks. And which seems to work.
However.. I also need to include the main data dump sheet within the source file (called "data") with the the array of files being copied over so that the links remain with the data sheet being copied over. If I write a line to copy over the data sheet separately, the new workbook still refers back to the source file, which service heads do not have access to.
So main question is: how can I add the "data" tab into the Sheets(CopyNames).Copy code so it is copied over with all the other files in the array at the same to keep the links intact?
Second question is if I decide it is the first two characters of the worksheet define the sheets that relate to a service head, how do I tweak the split/mid line of code - I've trialled around but am getting tied up in knots!
Any other tips to make the code more elegant much appreciated (there may be quite a long list of service head codes and I am sure there is a better way of creating a list for the routine to loop through)
Sub Copy_Sheets()
Dim strNames As String, strWSName As String
Dim arrNames, CopyNames
Dim wbAct As Workbook
Dim i As Long
Dim arrlist As Object
Set arrlist = CreateObject("system.collections.arraylist")
arrlist.Add "1234"
arrlist.Add "5678"
Set wbAct = ActiveWorkbook
For Each Item In arrlist
For i = 1 To Sheets.Count
strNames = strNames & "," & Sheets(i).Name
Next i
arrNames = Split(Mid(strNames, 2), ",")
'strWSName =("1234")
strWSName = Item
Application.ScreenUpdating = False
CopyNames = Filter(arrNames, strWSName, True, vbTextCompare)
If UBound(CopyNames) > -1 Then
Sheets(CopyNames).Copy
ActiveWorkbook.SaveAs Filename:=strWSName & " " & Format(Now, "dd-mmm-yy h-mm-ss")
ActiveWorkbook.Close
wbAct.Activate
Else
MsgBox "No sheets found: " & strWSName
End If
Next Item
Application.ScreenUpdating = True
End Sub
Option Explicit
Sub CopySheets()
With ThisWorkbook
Dim SheetIndex As Long
Dim ValidSheetNames() As String
ReDim ValidSheetNames(1 To .Worksheets.Count)
' Build a 1 dimensional array called ValidSheetNames, which contains every sheet in the master workbook other than DEDICATEDSHEET. '
Dim ws As Worksheet
For Each ws In .Worksheets
If ws.Name <> "DEDICATEDSHEET" Then
SheetIndex = SheetIndex + 1
ValidSheetNames(SheetIndex) = ws.Name
End If
Next ws
ReDim Preserve ValidSheetNames(1 To SheetIndex)
' Read all ServiceCodes into a 1-dimensional array '
Dim ServiceHeadCodes As Variant
ServiceHeadCodes = Application.Transpose(.Worksheets("DEDICATEDSHEET").Range("CCLIST[CC]").Value2)
Dim CodeIndex As Long
' Now loop through each ServiceHeadCode '
For CodeIndex = LBound(ServiceHeadCodes) To UBound(ServiceHeadCodes)
' Put all sheet names which contain the current ServiceHeadCode into an array called SheetsToCopy '
Dim SheetsToCopy() As String
SheetsToCopy = Filter(ValidSheetNames, ServiceHeadCodes(CodeIndex), True, vbTextCompare)
' Check if SheetToCopy now contains any sheet names at all. '
If UBound(SheetsToCopy) > -1 Then
' Add the name of the Data sheet to the end of the array '
ReDim Preserve SheetsToCopy(LBound(SheetsToCopy) To (UBound(SheetsToCopy) + 1))
SheetsToCopy(UBound(SheetsToCopy)) = "Data"
Dim OutputWorkbook As Workbook
Set OutputWorkbook = Application.Workbooks.Add
' Copy all sheets which are in SheetToCopy array to newly created OutputWorkbook '
.Worksheets(SheetsToCopy).Copy OutputWorkbook.Worksheets(1)
' Delete the default Sheet1, which should be at the end as copied sheets were inserted before it. '
' But suppress the Are you sure you want to delete this sheet.. message. '
Application.DisplayAlerts = False
OutputWorkbook.Worksheets(OutputWorkbook.Worksheets.Count).Delete
Application.DisplayAlerts = True
' Re-enable alerts, as we want to see any other dialogue boxes/messages
' Not providing a full directory path below means OutputWorkbook will be saved wherever Thisworkbook is saved.'
OutputWorkbook.SaveAs Filename:=ServiceHeadCodes(CodeIndex) & " " & Format(Now, "dd-mmm-yy h-mm-ss") & ".xlsx", FileFormat:=51
OutputWorkbook.Close
Else
MsgBox "No sheets found: " & ServiceHeadCodes(CodeIndex)
End If
Next CodeIndex
End With
End Sub
Untested and written on mobile, sorry for bad formatting.
This approach proposes that you store all service head codes in a 1-column Excel table on a dedicated sheet that is referred to via Excel table nomenclature (which might be easier than ArrayList.Add for each new service head code).
I assume code is stored in master workbook ('thisworkbook'), which might not be true.
You could modify the serviceheadcodes table directly on the spreadsheet itself, if you later decide that SheetsToCopy will be determined by first 2, 3 or X characters -- or you could modify array itself with left$() function.
Hope it works or gives you some ideas.
Edit: This is my sheet and table layout (which I assume matches yours).
And this is what the code above gives me on my computer.

Resources