Microsoft Philippines Community

Hi Guyz, is there a way to make this thing possible?:

 Heres my Sheet:

I want to make it programmatically that the output must be the following:

Thanks

what programming language are you supposed to used?

That was also my problem then, i used VB6 and I created a VB class module.

My solution:

Record a macro that will:

1. "Text to Columns" the text string in B1

2. Transpose the columns created in column B

3. Create a dynamic range in column A depending on the number of non-empty cells in column B and apply "fill down"

Here's the VBA code produced by Excel's macro recorder (relative recording mode). Note: Cell B1 must be the active cell, before you run the macro.

BTW, where are you going to use this?

Sub Macro1()
'
' Macro1 Macro
' Macro recorded 4/1/2007 by smb001
'

'
    Selection.TextToColumns Destination:=ActiveCell, DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1)), _
        TrailingMinusNumbers:=True
    ActiveCell.Offset(1, 0).Range("A1:A6").Select
    Selection.FormulaArray = "=TRANSPOSE(R[-1]C:R[-1]C[5])"
    ActiveCell.Offset(-1, -1).Range("A1").Select
    Selection.AutoFill Destination:=ActiveCell.Range("A1:A7"), Type:= _
        xlFillDefault
    ActiveCell.Range("A1:A7").Select
    ActiveCell.Offset(0, 1).Columns("A:A").EntireColumn.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveCell.Rows("1:1").EntireRow.Select
    Selection.Delete Shift:=xlUp
    ActiveCell.Select
End Sub

here's the code...

 add a class module.... copy this code.... the after that...

goto to project menu.. click references.... add Microsoft Excel 10.0 Object Library --> depends on the your office version( XP/2003 version)

Dim xlapp As Excel.Application
Dim xlbook As Workbook
Dim xlsheet As Worksheet
Dim fLoc As String

'OPEN EXCEL APPLICATION
Public Function Open_File(fileLoc As String, sheetNo As Integer, ShowMe As Boolean)
On Error GoTo Open_file_error
Set xlapp = CreateObject("Excel.Application")
Set xlbook = xlapp.Workbooks.Open(fileLoc)
Set xlsheet = xlbook.Worksheets(sheetNo)
fLoc = fileLoc
xlapp.Visible = ShowMe
Exit Function
Open_file_error:
MsgBox Err.Description, vbExclamation + vbOKOnly, "Open_File_Error"
Exit Function
End Function

'WRITE TEXT FOR SPECIFIC ROW,COLUMN
Public Sub PrinTtext(sText As String, rIndex, cIndex)
xlsheet.Cells(rIndex, cIndex) = sText
End Sub

'PRINT
Public Sub xlPrint(FromPage As Integer, ToPage As Integer, nCopies As Integer, wPreview As Boolean)
'If wPreview Then
'xlSheet.PrintPreview
'Else
xlsheet.PrintOut FromPage, ToPage, nCopies, wPreview
'End If
End Sub

'MERGEDCELL
Public Sub xlMerged(sRange1, Optional sRange2)
If IsMissing(sRange2) Then
xlsheet.Range(sRange1).Merge
Else
xlsheet.Range(sRange1, sRange2).Merge
End If
End Sub

'UNMERGED CELL
Public Sub xlUnMerged(sRange1, Optional sRange2)
If IsMissing(sRange2) Then
xlsheet.Range(sRange1).UnMerge
Else
xlsheet.Range(sRange1, sRange2).UnMerge
End If
End Sub

'SAVE WORKBOOK
Public Sub Save_Book(IsSave As Boolean)
xlbook.Saved = IsSave
End Sub

'CLOSE EXCEL APPLICATION ASK FOR SAVECHANGES
Public Sub Close_Excel(saveChanges As Boolean)
On Error GoTo Close_excel_Error
If saveChanges Then
xlbook.Close 1
Else
xlbook.Close 0
End If
xlapp.Quit
Set xlsheet = Nothing
Set xlbook = Nothing
Set xlapp = Nothing
Exit Sub
Close_excel_Error:
End Sub

'PAGESETUP = 1 INCH=72 0.5 INCH= 36
Public Sub SetUpPage(lftMargin, RytMargin, BottomMargin, TopMargin, orientation As XlPageOrientation, Optional sizePaper As XlPaperSize)
xlsheet.PageSetup.LeftMargin = lftMargin
xlsheet.PageSetup.RightMargin = RytMargin
xlsheet.PageSetup.BottomMargin = BottomMargin
xlsheet.PageSetup.TopMargin = TopMargin
If Not sizePaper = 0 Then
xlsheet.PageSetup.PaperSize = sizePaper
End If
xlsheet.PageSetup.orientation = orientation
End Sub

'SET FOOTER
Public Sub Footer(sFooter, sSection As Integer)
Select Case sSection
Case 1: 'left footer
xlsheet.PageSetup.LeftFooter = sFooter
Case 2: 'center footer
xlsheet.PageSetup.CenterFooter = sFooter
Case 3: 'ryt footer
xlsheet.PageSetup.RightFooter = sFooter
End Select
End Sub

'SET HEADER
Public Sub Header(sHeader, sSection As Integer)
Select Case sSection
Case 1: 'Left
xlsheet.PageSetup.LeftHeader = sHeader
Case 2: 'center
xlsheet.PageSetup.CenterHeader = sHeader
Case 3: 'ryt header
xlsheet.PageSetup.RightHeader = sHeader
End Select
End Sub

'BOLD AND UNBOLD TEXT
Public Sub Boldtext(MakeBold As Boolean, irange)
If MakeBold = True Then
xlsheet.Range(irange).Characters.Font.Bold = True
Else
xlsheet.Range(irange).Characters.Font.Bold = False
End If
End Sub

'ITALIC AND UNITALIC TEXT
Public Sub ItalicText(MakeItalic As Boolean, irange)
If MakeItalic = True Then
xlsheet.Range(irange).Characters.Font.Italic = True
Else
xlsheet.Range(irange).Characters.Font.Italic = False
End If
End Sub

'UNDERLINE TEXT
Public Sub UnderlineText(Undrline As Boolean, irange)
If Undrline = True Then
xlsheet.Range(irange).Characters.Font.Underline = True
Else
xlsheet.Range(irange).Characters.Font.Underline = False
End If
End Sub

'CHANGE FONT SIZE
Public Sub fontsize(Fsize As Integer, irange)
xlsheet.Range(irange).Characters.Font.Size = Fsize
End Sub

Public Sub fontName(fntName As String, irange)
xlsheet.Range(irange).Characters.Font.Name = fntName
End Sub
'CHANGE FONT ORIENTATION '90 0 -90
Public Sub FontOrientation(ndegree As Integer, irange)
xlsheet.Range(irange).orientation = ndegree
End Sub

'CHANGE TEXT ALIGNMENT
Public Sub FontAlignment(hAlign, vAlign, irange)
xlsheet.Range(irange).VerticalAlignment = vAlign
xlsheet.Range(irange).HorizontalAlignment = hAlign
End Sub

'PUT BORDER
Public Sub PutCellBorder(irange, weyt As Integer, isOneRow As Boolean)

'LEFT BORDER
With xlsheet.Range(irange).Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .Weight = weyt
    .ColorIndex = xlAutomatic
End With
'RIGHT BORDER
With xlsheet.Range(irange).Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .Weight = weyt
    .ColorIndex = xlAutomatic
End With
'BOTTOM BORDER
With xlsheet.Range(irange).Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .Weight = weyt
    .ColorIndex = xlAutomatic
End With
'TOP BORDER
With xlsheet.Range(irange).Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .Weight = weyt
    .ColorIndex = xlAutomatic
End With
'TOP BORDER INSIDE VERTICAL
With xlsheet.Range(irange).Borders(xlInsideVertical)
    .LineStyle = xlContinuous
    .Weight = weyt
    .ColorIndex = xlAutomatic
End With
'TOP BORDER INSIDE VERTICAL
If Not isOneRow Then
With xlsheet.Range(irange).Borders(xlInsideHorizontal)
    .LineStyle = xlContinuous
    .Weight = weyt
    .ColorIndex = xlAutomatic
End With
End If
End Sub

'HEIGHT OF THE CELL
Public Sub Heightxl(irange, xlHyt)
xlsheet.Range(irange).RowHeight = xlHyt
End Sub

'SET COLUMN WIDTH
Public Sub Widthxl(irange, xlwid)
xlsheet.Range(irange).ColumnWidth = xlwid
End Sub

'SAVEAS THE FILE
Public Sub SaveAsXL(SaveTo As String, fname As String, xlFormat As String)
xlbook.SaveAs SaveTo & fname & xlFormat
End Sub

'FILL COLOR
Public Sub Fill_cellColor(irange, cColor As OLE_COLOR)
xlsheet.Range(irange).Interior.Color = cColor
End Sub

'FILL TEXT COLOR
Public Sub Text_color(irange, cColor As OLE_COLOR)
xlsheet.Range(irange).Characters.Font.Color = cColor
End Sub

'DETERMINE THE PRINTABLE AREA OF THE PAPER
'THIS CODE IS UNDER MODIFICATION
Public Function PaperSizexl(widthHeight As Boolean) As Boolean
Dim WidofPaper As Double
Dim HytofPaper As Double
Dim xlPaperType As XlPaperSize
Dim totPaperWidth As Double
Dim totPaperHeight As Double
Dim countWidth As Double
Dim i As Integer
Dim xlP_orientation As XlPageOrientation

xlPaperType = xlsheet.PageSetup.PaperSize
xlP_orientation = xlsheet.PageSetup.orientation
'CONVERSION
'1 INCH=  72
'1 CM = 28.35
'129.27/11 = 11.78
Select Case (xlPaperType)
  'xlSheet.PageSetup.PaperSize = xlPaperLetter
  Case xlPaperLegal:
    WidofPaper = 612 '8.5 inches
    HytofPaper = 936 '13 inches
    PaperSizexl = False
  Case xlPaperLetter:
    WidofPaper = 612 '8.5 inches
    HytofPaper = 792 '11 inches
    PaperSizexl = True
End Select
End Function

Public Sub HideUnhideColumn(irange, IsHidden As Boolean)
xlapp.Columns(irange).Select
xlapp.Selection.EntireColumn.Hidden = IsHidden
End Sub

'WRITE TEXT TO SPECIFIC EXCEL RANGE
Public Sub PrintRangeText(xRange, sText As String)
xlsheet.Range(xRange) = sText
End Sub

'WRAP TEXT HERE
Public Sub Wrap_Text(irange, isWrap As Boolean)
xlsheet.Range(irange).WrapText = isWrap
End Sub

Public Sub Clear_Rowdata(irange)
xlsheet.Range(irange).Clear
End Sub

Public Function xl_TextValue(cRow, cCol) As String
xl_TextValue = ""
xl_TextValue = xlsheet.Cells(cRow, cCol).Text
End Function

Public Sub RepeatTitleRows(rStart, rEnd)
xlsheet.PageSetup.PrintTitleRows = "$" & rStart & ":$" & rEnd
End Sub

'PRINT ALL
Public Sub xlPrintAll(nCopies As Integer, wPreview As Boolean)
xlsheet.PrintOut , , nCopies, wPreview
End Sub

'COPY SHEET AND MOVE TO END
'SELECT THE SHEET AND SET THE SELECTED SHEET AS ACTIVE
Public Sub Copy_Sheets(SheetName As String)
xlapp.Sheets(1).Select
xlapp.Sheets(1).Copy After:=xlapp.Sheets(xlapp.Sheets.Count)
xlapp.Sheets(xlapp.Sheets.Count).Select
xlapp.Sheets(xlapp.Sheets.Count).Name = SheetName
Set xlsheet = xlbook.Worksheets(SheetName)
End Sub

'DELETE SHEET
Public Sub Delete_Sheets(shtName)
xlapp.Sheets(shtName).Select
xlapp.Sheets(shtName).Delete
End Sub

'FILL COLOR OF SELECTED ROW
Public Sub FillColor_Rows(irange, color_Index, ColorPattern As XlPattern)
xlapp.Range(irange).Select
With xlapp.Selection.Interior
    .ColorIndex = color_Index
    .Pattern = ColorPattern
End With
End Sub

'ADD COMMENT IN SPECIFIC RANGE
Public Sub AddComment(irange, new_Comment As String)
 xlapp.Range(irange).AddComment
 xlapp.Range(irange).Comment.Visible = False
 xlapp.Range(irange).Comment.Text Text:=new_Comment
End Sub

'FIND AND REPLACE
Public Sub FindAndReplace(WhatToFind As String, FindOnly As Boolean, Optional WhatToReplace As String)
With xlapp
    .Cells.Find(What:=WhatToFind, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
    If FindOnly = False Then
        .ActiveCell.Replace What:=WhatToFind, Replacement:=WhatToReplace, LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    End If
End With
End Sub

'FREEZE AND UNFREEZE PANES
Public Sub FreezeAndUnfreezePane(irange, isFreeze As Boolean)
With xlapp
    .Range(irange).Select
    .ActiveWindow.FreezePanes = isFreeze
End With
End Sub

'AUTO FILTER
Public Sub AutoFillMe(StartRange, startRange_text As String, Destination_range, xfillType As XlAutoFillType)
With xlapp
    .Range(StartRange).Select
    .ActiveCell.FormulaR1C1 = startRange_text
    .Range(StartRange).Select
    .Selection.AutoFill Destination:=Range(Destination_range), Type:=xfillType
    .Range(Destination_range).Select
End With
End Sub

'FORMAT THE CELLS
Public Sub FormatCells(irange, nFormat As String, hAlign As XlHAlign, vAlign As XlVAlign, Imerge As Boolean, Optional wrapMe As Boolean)
xlapp.Range(irange).Select
    '"@"=text
    '"General"=General
    '"0.00"=number with 2 decimal places
    xlapp.Selection.NumberFormat = nFormat
    With xlapp.Selection
        .HorizontalAlignment = hAlign
        .VerticalAlignment = vAlign
        .WrapText = wrapMe
        .orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = Imerge
       
    End With
End Sub

'Formula
Public Sub Formula(irange, iformula)
xlapp.Range(irange).Select
xlapp.ActiveCell.FormulaR1C1 = iformula
End Sub

'CUSTOMIZE BORDER
Public Sub CustomizeBorder(irange, bColor As XlColorIndex, Optional bLeft As XlLineStyle, Optional bRyt As XlLineStyle, Optional bTop As XlLineStyle, Optional bBottom As XlLineStyle, Optional bDiagonalUp As XlLineStyle, Optional bDiagonalDown As XlLineStyle, Optional bHorizontal As XlLineStyle, Optional bVertical As XlLineStyle)

With xlapp
    .Range(irange).Select
    .Selection.Borders(xlDiagonalDown).LineStyle = bDiagonalDown
    .Selection.Borders(xlDiagonalUp).LineStyle = bDiagonalUp
    .Selection.Borders(xlEdgeLeft).LineStyle = bLeft
    .Selection.Borders(xlEdgeTop).LineStyle = bTop
    .Selection.Borders(xlEdgeBottom).LineStyle = bBottom
    .Selection.Borders(xlEdgeRight).LineStyle = bRyt
    .Selection.Borders(xlInsideHorizontal).LineStyle = bHorizontal
    .Selection.Borders(xlInsideVertical).LineStyle = bVertical
    'sel.Weight = xlThin
    '.ColorIndex = xlAutomatic
End With
End Sub

Public Function GetColumnValue(irange) As String
GetColumnValue = xlapp.Range(irange).Text
End Function

Public Sub PutLines(iRow, iCol, weyt As Integer)
'LEFT BORDER
With xlsheet.Cells(iRow, iCol).Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .Weight = weyt
    .ColorIndex = xlAutomatic
End With
'RIGHT BORDER
With xlsheet.Cells(iRow, iCol).Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .Weight = weyt
    .ColorIndex = xlAutomatic
End With
'BOTTOM BORDER
With xlsheet.Cells(iRow, iCol).Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .Weight = weyt
    .ColorIndex = xlAutomatic
End With
'TOP BORDER
With xlsheet.Cells(iRow, iCol).Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .Weight = weyt
    .ColorIndex = xlAutomatic
End With
End Sub

'PREVIEW
Public Sub Preview(wPreview As Boolean)
xlsheet.PrintPreview wPreview
End Sub

Public Sub ViewMe(wView As Boolean)
xlapp.Visible = wView
End Sub

Public Sub SetUpMyPage(PageOrientation As XlPageOrientation, SizeOfPaper As XlPaperSize, Optional HeaderLeft As String, Optional HeaderCenter As String, Optional HeaderRight As String, Optional FooterLeft As String, Optional FooterCenter As String, Optional FooterRight As String, _
                    Optional MarginLeft As Double, Optional MarginRight As Double, Optional MarginTop As Double, Optional MarginBottom As Double, Optional MarginHeader As Double, Optional MarginFooter As Double, _
                    Optional CenterHorizontal As Boolean, Optional CenterVertical As Boolean, Optional DraftPrint As Boolean)
With xlapp.ActiveSheet.PageSetup
        .LeftHeader = HeaderLeft
        .CenterHeader = HeaderCenter
        .RightHeader = HeaderRight
        .LeftFooter = FooterLeft
        '"&""Code 39 JK,Regular""&18*ADRIAN*"
        '"&""Code 39 JK,Regular""adrian&""Arial,Regular"" &""Arial Narrow,Regular""adrian"
        .CenterFooter = FooterCenter
        .RightFooter = FooterRight
        .LeftMargin = Application.InchesToPoints(MarginLeft)
        .RightMargin = Application.InchesToPoints(MarginRight)
        .TopMargin = Application.InchesToPoints(MarginTop)
        .BottomMargin = Application.InchesToPoints(MarginBottom)
        .HeaderMargin = Application.InchesToPoints(MarginHeader)
        .FooterMargin = Application.InchesToPoints(MarginFooter)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = CenterHorizontal
        .CenterVertically = CenterVertical
        .orientation = PageOrientation
        .Draft = DraftPrint
        .PaperSize = SizeOfPaper
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 100
        .PrintErrors = xlPrintErrorsDisplayed
    End With
End Sub