Attribute VB_Name = "Latex" ' xl2latex: excel table to latex tabular converter ' ' works only with excel97 (and hopefully above, you never know what microsoft does) ' for color, package "colortbl" is needed (put \usepackage{colortbl} in preamble) ' ' version: 0.9.3 ' date: 2001-08-14 ' copyright (c) 2001 ronny buchmann ' ' ideas taken from Excel2Latex by joachim marder ' ' This program is free software; you can redistribute it and/or ' modify it under the terms of the GNU General Public License ' as published by the Free Software Foundation; either version 2 ' of the License, or (at your option) any later version. ' ' This program is distributed in the hope that it will be useful, ' but WITHOUT ANY WARRANTY; without even the implied warranty of ' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ' GNU General Public License for more details. ' ' You should have received a copy of the GNU General Public License ' along with this program; if not, write to the Free Software ' Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA ' or visit http://www.gnu.org ' ' attention: ' - text without specific alignment (text left, numbers right) is right aligned in latex, if ' you want it other, format the cells that way ' or shorter: numbers prefered ' ' features: ' - merged cells (only horizontal, because auf latex) ' - text centered across cells ' - colored cells ' - colored text ' - latex math in cells ' - normal and double borders (with latex limits) ' - hidden rows and columns are ignored ' - cells with wrapped text (uses excels cell width) ' ' todo: ' - cells with wrapped text could be improved i think ' - font sizes ' ' not-todo: ' - vertical merged cells -> the only always working way i see are tables inside tables, too difficult, really ' one solution would be the use of \raisebox, if you want it put in in the cell Sub xl2latex() Dim selcells As Object 'selected cells Dim texfile As Variant 'filename Dim file As Integer 'filehandle Dim r As Object 'row Dim i, j, k As Integer 'indices Dim colored As Boolean If Selection Is Nothing Then Beep: Exit Sub 'save in directory of current file ChDir (ActiveWorkbook.Path) ChDrive (Left(ActiveWorkbook.Path, 1)) texfile = ActiveSheet.Name & ".tex" texfile = Application.GetSaveAsFilename(texfile, "LaTeX files (*.tex), *.tex", , "File export") If texfile = False Then Exit Sub file = FreeFile(0) Open texfile For Output As #file Set selcells = Selection Call head(file, selcells) If selcells.Rows(1).Borders(xlEdgeTop).LineStyle <> xlLineStyleNone Then Print #file, "\hline" For i = 1 To selcells.Rows.Count ' for each row Set r = selcells.Rows(i) If r.Rows.Hidden = False Then ' hidden row? For j = 1 To r.cells.Count ' foreach cell in row If ActiveSheet.Columns(selcells.Columns(j).Column).Hidden = False Then ' hidden column? ' check for multicolumns multicells = 0 If r.cells(j).HorizontalAlignment = xlHAlignCenterAcrossSelection Then multicells = 1 For k = 1 To r.cells.Count - j 'rest of the row If r.cells(j + k).HorizontalAlignment = xlHAlignCenterAcrossSelection _ And ActiveSheet.Columns(r.cells(j + k).Column).Hidden = False Then If r.cells(j + k) = "" Then 'centering across cells works until next filled cell multicells = multicells + 1 Else Exit For End If End If Next k 'get multicolumn width alignment = "c" End If If r.cells(j).MergeCells = True Then multicells = 1 For k = 1 To r.cells.Count - j 'rest of the row 'merged cell has same column and is not hidden If r.cells(j + k).MergeArea.Column = r.cells(j).Column _ And ActiveSheet.Columns(r.cells(j + k).Column).Hidden = False Then multicells = multicells + 1 End If Next k 'get multicolumn width alignment = align(r.cells(j)) End If If r.cells(j).Interior.color <> RGB(255, 255, 255) Then If multicells = 0 Then multicells = 1 alignment = align(r.cells(j)) colored = True Else colored = False End If If multicells > 0 Then 'multicolumn code needed Print #file, "\multicolumn{"; CStr(multicells); "}"; Print #file, "{"; leftborder(r.cells, j); 'latex prints bold border, strange! If colored = True Then Print #file, bgcolor(r.cells(j).Interior.color); Print #file, alignment; rightborder(r.cells, j, multicells); "}"; Print #file, "{"; text(r.cells(j)); "}"; j = j + multicells - 1 Else 'normal cell Print #file, text(r.cells(j)); End If If j < r.cells.Count Then Print #file, " & "; End If ' hidden column Next j 'next column Print #file, " \\" If r.Borders(xlEdgeBottom).LineStyle <> xlLineStyleNone Then If r.Borders(xlEdgeBottom).LineStyle = xlDouble Then Print #file, "\hline" End If Print #file, "\hline" End If End If 'hidden row Next i 'next row 'end Print #file, "\end{tabular}" Close #file End Sub ' print table head Function head(ByVal file As Integer, selcells As Range) Dim i As Integer Print #file, "\begin{tabular}{"; Print #file, leftborder(selcells, 1); For i = 1 To selcells.Columns.Count If ActiveSheet.Columns(selcells.Columns(i).Column).Hidden = False Then Print #file, align(selcells.Columns(i)); Print #file, rightborder(selcells, i, 1); End If Next i Print #file, "}" End Function ' get alignment of cells Function align(sel As Range) Dim tmpsel As Range If sel.HorizontalAlignment <> Null Then Set tmpsel = sel Else 'unknown alignment for whole column, use first row instead Set tmpsel = sel.Rows(1) End If Select Case tmpsel.HorizontalAlignment Case xlHAlignLeft align = "l" Case xlHAlignCenter align = "c" Case Else 'right align for numbers, do manual left align for text align = "r" End Select End Function ' get left border of cell Function leftborder(actrow As Range, ByVal colindex As Integer) leftborder = "" If colindex = 1 Then If actrow(1).Borders(xlEdgeLeft).LineStyle <> xlLineStyleNone Then leftborder = "|" If actrow(1).Borders(xlEdgeLeft).LineStyle = xlDouble Then leftborder = "||" Else If (actrow(colindex).Borders(xlEdgeLeft).LineStyle <> xlLineStyleNone) Or _ (actrow(colindex - 1).Borders(xlEdgeRight).LineStyle <> xlLineStyleNone) Then leftborder = "|" If (actrow(colindex).Borders(xlEdgeLeft).LineStyle = xlDouble) Or _ (actrow(colindex - 1).Borders(xlEdgeRight).LineStyle = xlDouble) Then leftborder = "||" End If End If End If End Function ' get right border of cell Function rightborder(actrow As Range, ByVal colindex As Integer, ByVal colwidth As Integer) If (actrow(colindex + colwidth - 1).Borders(xlEdgeRight).LineStyle <> xlLineStyleNone) Or _ (actrow(colindex + colwidth).Borders(xlEdgeLeft).LineStyle <> xlLineStyleNone) Then rightborder = "|" If (actrow(colindex + colwidth - 1).Borders(xlEdgeRight).LineStyle = xlDouble) Or _ (actrow(colindex + colwidth).Borders(xlEdgeLeft).LineStyle = xlDouble) Then rightborder = rightborder & "|" End If Else rightborder = "" End If End Function ' color attribute of cell (background) Function bgcolor(ByVal color As Long) bgcolor = ">{\columncolor[rgb]{" & rgbcolor(color) & "}}" End Function ' color attribute of text (foreground) Function fgcolor(ByVal color As Long) fgcolor = "\textcolor[rgb]{" & rgbcolor(color) & "}" End Function ' convert excel color to latex rgb Function rgbcolor(ByVal color As Long) Dim red, green, blue As Single blue = color \ 65536 green = (color - (blue * 65536)) \ 256 red = (color - (blue * 65536) - (green * 256)) blue = blue / 255 green = green / 255 red = red / 255 rgbcolor = Format(red, "0.000") & "," & Format(green, "0.000") & "," & Format(blue, "0.000") rgbcolor = Left(rgbcolor, 1) & "." & Mid(rgbcolor, 3, 5) & "." & Mid(rgbcolor, 9, 5) _ & "." & Right(rgbcolor, 3) End Function ' text in cell Function text(actcell As Range) Dim pos As Integer text = actcell.text ' quote special chars pos = InStr(text, "%") If (pos > 0) Then 'comment doesnt make sense within table text = Mid(text, 1, pos - 1) & "\" & Mid(text, pos, Len(text)) End If pos = InStr(text, "$") If (pos > 0) Then If (InStr(pos + 1, text, "$") = 0) Then 'currencies appear only once and have to be quoted text = Mid(text, 1, pos - 1) & "\" & Mid(text, pos, Len(text)) End If End If If actcell.Font.color <> 0 Then 'colored text text = fgcolor(actcell.Font.color) & "{" & text & "}" End If ' set font style If actcell.Font.Bold Then text = "{\textbf " & text & "}" If actcell.Font.Italic Then text = "{\textit " & text & "}" ' wrapped text If actcell.WrapText = True Then text = "\parbox{" & actcell.width & "pt}{" & text & "}" End Function ' load toolbar Sub loadtoolbar() Dim i As Integer For i = 1 To CommandBars.Count If CommandBars(i).Name = "LaTeX" Then GoTo later Next i CommandBars.Add Name:="LaTeX" later: CommandBars("LaTeX").Visible = False CommandBars("LaTeX").Position = msoBarTop 'overwrite the Excel2Latex button since Excel2LaTeX is now obsolete With CommandBars("LaTeX") If .Controls.Count = 0 Then .Controls.Add .Controls(1).FaceId = 244 .Controls(1).Caption = "LaTeX export" .Controls(1).DescriptionText = "Export selection as LaTeX table" .Controls(1).TooltipText = .Controls(1).DescriptionText .Controls(1).OnAction = "xl2latex" .Visible = True End With End Sub Sub Auto_Open() ThisWorkbook.Windows(1).Visible = False 'hide the sheets, only a macro is here Call loadtoolbar End Sub Sub Auto_Close() Call loadtoolbar End Sub