Excel VBA macros for data set [closed] - vba

Question

Closed. This question needs to be more focused. It is not currently accepting answers.
Want to improve this question? Update the question so it focuses on one problem only by editing this post.
Closed 6 years ago.
Improve this question
I need to create a csv file from data set matrix, in which I have materials as a rows, people as a columns and quantity of products on intersection. Here is an example of this data set (Order id #1000):
Materials Person1 Person2
563718 20 40
837563 15 35
As a first action I have to transform this data set to a linear structure in this way on additional sheet:
Orderid Material Person Qty
1000 563718 Person1 20
1000 837563 Person1 15
1000 563718 Person2 40
1000 837563 Person2 35
And from this linear structure I have to generate a csv file with Orders for another system based on unique Persons from the list above. Each Order should have one header line and details based on the number of materials he/she ordered. General structure is the following:
H,1000-1,OUT,20160830,Person1
l,1000-1,1,563718,20,EA
l,1000-1,2,837563,15,EA
H,1000-2,OUT,20160830,Person2
l,1000-2,1,563718,40,EA
l,1000-2,2,837563,15,EA
where "H" - means Header row, "1000-1" - first Sub-Order of a Global order 1000, "20160830" requested delivery date, "l" - line row, "1" - line number, "EA" - unit of measure.

Answer 1

Here's a macro that will get you most of the way. It takes the data in your first table and organizes it so that your date in like columns (person1 and person2) is separated into separate rows:
This script assumes that your fixed column(s) are on the left and the columns to be combined (and split out into multiple rows) follow on the right. I hope this helps!
Option Explicit
Sub MatrixConverter2_3()
' Macro created 11/16/2005 by Peter T Oboyski (updated 8/24/2006)
'
' *** Substantial changes made by Chris Brackett (updated 8/3/2016) ***
'
' You are welcome to redistribute this macro, but if you make substantial
' changes to it, please indicate so in this section along with your name.
' This Macro converts matrix-type spreadsheets (eg. plot x species data) into column data
' The new (converted) spreadsheet name is "DB of 'name of active spreadsheet'"
' The conversion allows for multiple header rows and columns.
'--------------------------------------------------
' This section declares variables for use in the script
Dim book, head, cels, mtrx, dbase, v, UserReady, columnsToCombine, RowName, DefaultRowName, DefaultColName1, DefaultColName2, ColName As String
Dim defaultHeaderRows, defaultHeaderColumns, c, r, selectionCols, ro, col, newro, newcol, rotot, coltot, all, rowz, colz, tot As Long
Dim headers(100) As Variant
Dim dun As Boolean
'--------------------------------------------------
' This section sets the script defaults
defaultHeaderRows = 1
defaultHeaderColumns = 2
DefaultRowName = "Activity"
'--------------------------------------------------
' This section asks about data types, row headers, and column headers
UserReady = MsgBox("Have you selected the entire data set (not the column headers) to be converted?", vbYesNoCancel)
If UserReady = vbNo Or UserReady = vbCancel Then GoTo EndMatrixMacro
all = MsgBox("Exclude zeros and empty cells?", vbYesNoCancel)
If all = vbCancel Then GoTo EndMatrixMacro
' UN-COMMENT THIS SECTION TO ALLOW FOR MULTIPLE HEADER ROWS
rowz = 1
' rowz = InputBox("How many HEADER ROWS?" & vbNewLine & vbNewLine & "(Usually 1)", "Header Rows & Columns", defaultHeaderRows)
' If rowz = vbNullString Then GoTo EndMatrixMacro
colz = InputBox("How many HEADER COLUMNS?" & vbNewLine & vbNewLine & "(These are the columns on the left side of your data set to preserve as is.)", "Header Rows & Columns", defaultHeaderColumns)
If colz = vbNullString Then GoTo EndMatrixMacro
'--------------------------------------------------
' This section allows the user to provide field (column) names for the new spreadsheet
selectionCols = Selection.Columns.Count ' get the number of columns in the selection
For r = 1 To selectionCols
headers(r) = Selection.Cells(1, r).Offset(rowOffset:=-1, columnOffset:=0).Value ' save the column headers to use as defaults for user provided names
Next r
colz = colz * 1
columnsToCombine = "'" & Selection.Cells(1, colz + 1).Offset(rowOffset:=-1, columnOffset:=0).Value & "' to '" & Selection.Cells(1, selectionCols).Offset(rowOffset:=-1, columnOffset:=0).Value & "'"
Dim Arr(20) As Variant
newcol = 1
For r = 1 To rowz
If r = 1 Then RowName = DefaultRowName
Arr(newcol) = InputBox("Field name for the fields/columns to be combined" & vbNewLine & vbNewLine & columnsToCombine, , RowName)
If Arr(newcol) = vbNullString Then GoTo EndMatrixMacro
newcol = newcol + 1
Next
For c = 1 To colz
ColName = headers(c)
Arr(newcol) = InputBox("Field name for column " & c, , ColName)
If Arr(newcol) = vbNullString Then GoTo EndMatrixMacro
newcol = newcol + 1
Next
Arr(newcol) = "Data"
v = newcol
'--------------------------------------------------
' This section creates the new spreadsheet, names it, and color codes the new worksheet tab
mtrx = ActiveSheet.Name
Sheets.Add After:=ActiveSheet
dbase = "DB of " & mtrx
'--------------------------------------------------
' If the proposed worksheet name is longer than 28 characters, truncate it to 29 characters.
If Len(dbase) > 28 Then dbase = Left(dbase, 28)
'--------------------------------------------------
' This section checks if the proposed worksheet name
' already exists and appends adds a sequential number
' to the name
Dim sheetExists As Variant
Dim Sheet As Worksheet
Dim iName As Integer
Dim dbaseOld As String
dbaseOld = dbase ' save the original proposed name of the new worksheet
iName = 0
sheetExists = False
CheckWorksheetNames:
For Each Sheet In Worksheets ' loop through every worksheet in the workbook
If dbase = Sheet.Name Then
sheetExists = True
iName = iName + 1
dbase = Left(dbase, Len(dbase) - 1) & " " & iName
GoTo CheckWorksheetNames
' Exit For
End If
Next Sheet
'--------------------------------------------------
' This section notify the user if the proposed
' worksheet name is already being used and the new
' worksheet was given an alternate name
If sheetExists = True Then
MsgBox "The worksheet '" & dbaseOld & "' already exists. Renaming to '" & dbase & "'."
End If
'--------------------------------------------------
' This section creates and names a new worksheet
On Error Resume Next 'Ignore errors
If Sheets("" & Range(dbase) & "") Is Nothing Then ' If the worksheet name doesn't exist
ActiveSheet.Name = dbase ' Rename newly created worksheet
Else
MsgBox "Cannot name the worksheet '" & dbase & "'. A worksheet with that name already exists."
GoTo EndMatrixMacro
End If
On Error GoTo 0 ' Resume normal error handling
Sheets(dbase).Tab.ColorIndex = 41 ' color the worksheet tab
'--------------------------------------------------
' This section turns off screen and calculation updates so that the script
' can run faster. Updates are turned back on at the end of the script.
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'--------------------------------------------------
'This section determines how many rows and columns the matrix has
dun = False
rotot = rowz + 1
Do
If (Sheets(mtrx).Cells(rotot, 1) > 0) Then
rotot = rotot + 1
Else
dun = True
End If
Loop Until dun
rotot = rotot - 1
dun = False
coltot = colz + 1
Do
If (Sheets(mtrx).Cells(1, coltot) > 0) Then
coltot = coltot + 1
Else
dun = True
End If
Loop Until dun
coltot = coltot - 1
'--------------------------------------------------
'This section writes the new field names to the new spreadsheet
For newcol = 1 To v
Sheets(dbase).Cells(1, newcol) = Arr(newcol)
Next
'--------------------------------------------------
'This section actually does the conversion
tot = 0
newro = 2
For col = (colz + 1) To coltot
For ro = (rowz + 1) To rotot 'the next line determines if data are nonzero
If ((Sheets(mtrx).Cells(ro, col) <> 0) Or (all <> 6)) Then 'DCB modified ">0" to be "<>0" to exclude blank and zero cells
tot = tot + 1
newcol = 1
For r = 1 To rowz 'the next line copies the row headers
Sheets(dbase).Cells(newro, newcol) = Sheets(mtrx).Cells(r, col)
newcol = newcol + 1
Next
For c = 1 To colz 'the next line copies the column headers
Sheets(dbase).Cells(newro, newcol) = Sheets(mtrx).Cells(ro, c)
newcol = newcol + 1
Next 'the next line copies the data
Sheets(dbase).Cells(newro, newcol) = Sheets(mtrx).Cells(ro, col)
newro = newro + 1
End If
Next
Next
'--------------------------------------------------
'This section displays a message box with information about the conversion
book = "Original matrix = " & ActiveWorkbook.Name & ": " & mtrx & Chr(10)
head = "Matrix with " & rowz & " row headers and " & colz & " column headers" & Chr(10)
cels = tot & " cells of " & ((rotot - rowz) * (coltot - colz)) & " with data"
'--------------------------------------------------
' This section turns screen and calculation updates back ON.
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox (book & head & cels)
'--------------------------------------------------
' This is an end point for the macro
EndMatrixMacro:
End Sub

Answer 2

Thanks #ChrisB for your answer. Actually I decided to do it my own way and here are the main steps I did:
I created an Excel file with several buttons to which I assigned below Subroutines. Also I have added some parameters, which user can modify (OrderId, Delivery Date and WH id).
I created a Subroutine ReadData(), which clears the Sheet "DATA" in original file and after reads column by column in the data file and generates a linear data set with all required fields on "DATA" Sheet.
After that I simply writes "DATA" sheet to external csv file.
the final code looks like this:
Global Const DAODBEngine = "DAO.DBEngine.36"
Global intColBeg As Integer 'Column Index with Data set to analyze
Global intRowBeg As Integer 'Row Index with Data set to analyze
Sub FileOpen()
Dim filePath As String
filePath = Application.GetOpenFilename()
If filePath = "False" Then Exit Sub
ThisWorkbook.Sheets("BASE").Cells(4, 3) = filePath
End Sub
Sub ClearData()
' Check if DATA Sheet exists
If Evaluate("ISREF('" & "DATA" & "'!A1)") Then
Application.DisplayAlerts = False
ThisWorkbook.Sheets("DATA").Delete
Application.DisplayAlerts = True
End If
Dim sheet As Worksheet
ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = "DATA"
End Sub
' This function reads data and adds it to DATA Sheet
Sub ReadData()
Dim i As Integer, l As Integer
Dim intColumn As Integer, intRow As Integer
Dim intAddRow As Integer
Dim wbCopyFrom As Workbook
Dim wbCopyTo As Workbook
Dim wsCopyFrom As Worksheet
Dim wsCopyTo As Worksheet
Dim dataLoc As String, wbLoc As String
Dim mandant As String
Dim orderId As String
Dim orderNum As Integer
Dim shipDate As Date
dataLoc = Trim(ThisWorkbook.Sheets("BASE").Cells(4, 3).Text)
Set wbCopyFrom = Workbooks.Open(dataLoc)
Set wsCopyFrom = wbCopyFrom.Worksheets(1)
ThisWorkbook.Activate
Call ClearData ' Clears all the data on DATA Sheet
Set wbCopyTo = ThisWorkbook
Set wsCopyTo = wbCopyTo.Sheets("DATA")
wbCopyTo.Activate
mandant = wbCopyTo.Sheets("BASE").Cells(11, 3).Text
orderId = wbCopyTo.Sheets("BASE").Cells(7, 3).Text
shipDate = wbCopyTo.Sheets("BASE").Cells(9, 3).Text
' Initial upper left row/column where matrix data begins
intColBeg = 4
intRowBeg = 4
intColumn = intColBeg
intRow = intRowBeg
intAddRow = 1 ' We will add data from this row
orderNum = 1
While Trim(wsCopyFrom.Cells(intRowBeg - 1, intColumn).Text) <> ""
' Header of an Order
wsCopyTo.Cells(intAddRow, 1) = "H;OUT;" & mandant & ";" & orderId & "/" & orderNum & ";" & _
";;" & Mid(shipDate, 7, 4) & Mid(shipDate, 4, 2) & Mid(shipDate, 1, 2) & ";" & _
Trim(wsCopyFrom.Cells(3, intColumn).Text) & ";" & Trim(wsCopyFrom.Cells(2, intColumn).Text) & _
";;;;;;;999;;"
Dim r As Integer
r = 1
intAddRow = intAddRow + 1
While Trim(wsCopyFrom.Cells(intRow, intColBeg - 1).Text) <> ""
If (Trim(wsCopyFrom.Cells(intRow, intColumn).Text) <> "") Then
If Round(CDbl(Trim(wsCopyFrom.Cells(intRow, intColumn).Value)), 0) > 0 Then
' Rows of an Order
wsCopyTo.Cells(intAddRow, 1) = "I;" & orderId & "/" & orderNum & ";" & r & ";" & _
Trim(wsCopyFrom.Cells(intRow, 1).Text) & ";" & Trim(wsCopyFrom.Cells(intRow, intColumn).Value) & _
";PCE;;;;;;;;;;;;;;;"
r = r + 1
intAddRow = intAddRow + 1
End If
End If
intRow = intRow + 1
Wend
intRow = intRowBeg
intColumn = intColumn + 1
orderNum = orderNum + 1
Wend
wbCopyFrom.Close
wbCopyTo.Sheets("BASE").Activate
End Sub
Sub Export()
Dim MyPath As String
Dim MyFileName As String
MyFileName = "Orders_" & Sheets("BASE").Cells(7, 3).Text & "_" & Format(Date, "ddmmyyyy")
If Not Right(MyFileName, 4) = ".csv" Then MyFileName = MyFileName & ".csv"
Sheets("DATA").Copy
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = "" '<~~ The start folder path for the file picker.
If .Show <> -1 Then GoTo NextCode
MyPath = .SelectedItems(1) & "\"
End With
NextCode:
If MyPath <> "" Then
Application.DisplayAlerts = False
With ActiveWorkbook
.SaveAs fileName:=MyPath & MyFileName, AccessMode:=xlExclusive, FileFormat:=xlCSV, CreateBackup:=False, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
.Close False
End With
Application.DisplayAlerts = True
Else
On Error Resume Next
ActiveWorkbook.Close SaveChanges:=False
If Err.Number = 1004 Then
On Error GoTo 0
End If
End If
End Sub
I believe that this code isn't optimal as I don't have any experience in VBA and it was a method of trying/changing/trying again in debugging mode and googling in case of issues.
If you can provide any suggestion how to optimise it - that would be great!