请参阅

http://blog.sciencenet.cn/blog-255662-849868.html

https://github.com/helixcn/herblabel

使用 herblabel程序包生成植物标本采集标签。

早在2006年， 一起和同门的陈彬博士在云南出野外时， 陈博士就提供了一个打印植物采集标签的Excel小程序。 因为我当时完全不懂编程， 觉得很神奇， 程序虽然很小，但是确实提供了很多方便。

进入嘉道理农场工作以来， 我的工作包括采集标本。 从采集记录快速生成采集标签的需求又一次摆在我面前。 但是陈彬博士提供的excel程序各部分都是中文， 但是我需要输入英文， 标签的格式也要进行相应的调整。 基于他提供的VBA程序， 我对VBA的源代码进行了修改， 调整了输出标签的格式，以及字体， 每一行的大小， 以及插入分隔符的位置等。

实现的功能
输入 在sheet1中按照要求相应的采集信息， 执行本命令， 例如用按钮关联，在sheet2中就可以生成固定的标签。

以下是Excel VBA中的源代码。 供感兴趣的读者参考， 并欢迎提出宝贵意见。 ''#########################################################################

''########## This macro was developed Dr. JinlongZhang  base on ##########

''################# a  VBA macro by Dr.  Bin Chen #########################

''################# Email : jinlongzhang01@gmail.com ####################

''#########################  30/01/2013###################################

''#########################################################################

Dim a, b, c, d,e, f, g As Integer  'Definition of the variables

'Maximum Number of labels can be created

'b

Sheet2.Columns.Clear

Sheet2.ResetAllPageBreaks

Sheet2.DisplayPageBreaks = False

c = 1                               '

d = 0

For a = 2 To 50000

   If Sheet1.Cells(a, 1) = "" Then

      MsgBox "Please find the labels in Sheet 2"

       Exit For

   Else

       g =Sheet1.Cells(a, 16)   ' Numberof copies for one collection number

       For b = 1 To g

            If d > 1 And (d Mod 8 = 0 Or d Mod 8 = 1) Then 'Ajustingthe margins, and number of labels per page.

              f = 13

            Else

              f = 14

            End If

        If d > 1 And (d Mod 2 = 0) Then

           c = c + f

       End If

           e = (d + 1) Mod 2

If e = 1 Then

  Sheet2.Cells(c, 1) = TextBox1.Text

  Sheet2.Cells(c + 1, 1) = TextBox2.Text

  Sheet2.Cells(c + 2, 1) = Sheet1.Cells(a, 4) '"Species: "

  Sheet2.Cells(c + 3, 1) = Sheet1.Cells(a, 5) ' "Infraspecies: "

  Sheet2.Cells(c + 4, 1) = "Family: " +Sheet1.Cells(a, 8)

  Sheet2.Cells(c + 5, 1) = "Local Name: " +Sheet1.Cells(a, 6)

  Sheet2.Cells(c + 6, 1) = "Field Note: " +Sheet1.Cells(a, 9)

  Sheet2.Cells(c + 7, 1) = "Locality: " +Sheet1.Cells(a, 17)

  Sheet2.Cells(c + 8, 1) = "Lon/Lat/Alt: " +Sheet1.Cells(a, 18) + "/" +Sheet1.Cells(a, 19) + "/" +Sheet1.Cells(a, 20) + "m"

  Sheet2.Cells(c + 9, 1) = "Col. & Num: " + Sheet1.Cells(a, 2) + " " +Sheet1.Cells(a, 1)

  Sheet2.Cells(c + 10, 1) = "Date Col.: " +Sheet1.Cells(a, 3)

  Sheet2.Cells(c + 11, 1) = "Det. & Date: " + Sheet1.Cells(a, 24) + "/" +Sheet1.Cells(a, 25)

  Sheet2.Cells(c + 12, 1) = "Note: " +Sheet1.Cells(a, 13)

   With Sheet2  'applicaton    ' Adjusting the display of the text

       'Set height for rows

       .Range(.Cells(c,1), .Cells(c+ 12, 1)).RowHeight = 12

       'Set width for columns

       .Range(.Cells(c,1), .Cells(c+ 12, 1)).ColumnWidth = 42

       .Range(.Cells(c,1), .Cells(c+ 12, 1)).Font.Name = "Arial"

       .Range(.Cells(c,1), .Cells(c+ 12, 1)).Font.Size = 11       'Size

       .Range(.Cells(c,1), .Cells(c+ 12, 1)).HorizontalAlignment = xlGeneral

       .Range(.Cells(c,1), .Cells(c+ 12, 1)).VerticalAlignment = xlCenter

       .Range(.Cells(c,1), .Cells(c+ 12, 1)).WrapText = False

       .Range(.Cells(c,1), .Cells(c+ 12, 1)).Orientation = 0

       .Range(.Cells(c,1), .Cells(c+ 12, 1)).AddIndent = False

       .Range(.Cells(c,1), .Cells(c+ 12, 1)).IndentLevel = 0

       .Range(.Cells(c,1), .Cells(c+ 12, 1)).ShrinkToFit = True

       .Range(.Cells(c,1), .Cells(c+ 12, 1)).ReadingOrder = xlContext

       .Range(.Cells(c,1), .Cells(c+ 12, 1)).MergeCells = False

   End With

   With Sheet2.Cells(c, 1)  'Adjusting the Title, right

       .Font.Name= "Arial" 'Font

       .Font.Size= 12     'Size

       .Font.Bold= True   'Alignment

       .HorizontalAlignment= xlCenter

       .VerticalAlignment= xlCenter

       .WrapText= False

       .Orientation= 0

       .AddIndent= False

       .IndentLevel= 0

       .ShrinkToFit= True

       .ReadingOrder= xlContext

       .MergeCells= False

   End With

   With Sheet2.Cells(c + 1, 1)   ' Formatthe subtitle

       .HorizontalAlignment= xlCenter

       .VerticalAlignment= xlCenter

       .Font.Name= "Times New Roman" 'Font

       .Font.Size= 12     'Size

   End With

ElseIf e = 0 Then

  Sheet2.Cells(c, 2) = TextBox1.Text          'Title

  Sheet2.Cells(c + 1, 2) = TextBox2.Text      'Subtitle

  Sheet2.Cells(c + 2, 2) = Sheet1.Cells(a, 4) '"Species: "

  Sheet2.Cells(c + 3, 2) = Sheet1.Cells(a, 5) ' "Infraspecies: "

  Sheet2.Cells(c + 4, 2) = "Family: " +Sheet1.Cells(a, 8)

  Sheet2.Cells(c + 5, 2) = "Local Name: " +Sheet1.Cells(a, 6)

  Sheet2.Cells(c + 6, 2) = "Field Note: " +Sheet1.Cells(a, 9)

  Sheet2.Cells(c + 7, 2) = "Locality: " +Sheet1.Cells(a, 17)

  Sheet2.Cells(c + 8, 2) = "Lon/Lat/Alt: " +Sheet1.Cells(a, 18) + "/" +Sheet1.Cells(a, 19) + "/" +Sheet1.Cells(a, 20) + "m"

  Sheet2.Cells(c + 9, 2) = "Col. & Num: " + Sheet1.Cells(a, 2) + " " +Sheet1.Cells(a, 1)

  Sheet2.Cells(c + 10, 2) = "Date Col.: " +Sheet1.Cells(a, 3)

  Sheet2.Cells(c + 11, 2) = "Det. & Date: " + Sheet1.Cells(a, 24) + "/" +Sheet1.Cells(a, 25)

  Sheet2.Cells(c + 12, 2) = "Note: " +Sheet1.Cells(a, 13)

   With Sheet2  'applicaton

       .Range(.Cells(c,2), .Cells(c+ 12, 2)).RowHeight = 12         'Setheight for rows

       .Range(.Cells(c,2), .Cells(c+ 12, 2)).ColumnWidth = 42       'Setwidth for columns

       .Range(.Cells(c,2), .Cells(c+ 12, 2)).Font.Name = "Arial"

       .Range(.Cells(c,2), .Cells(c+ 12, 2)).Font.Size = 11          'Size

       .Range(.Cells(c,2), .Cells(c+ 12, 2)).HorizontalAlignment = xlGeneral

       .Range(.Cells(c,2), .Cells(c+ 12, 2)).VerticalAlignment = xlCenter

       .Range(.Cells(c,2), .Cells(c+ 12, 2)).WrapText = False

       .Range(.Cells(c,2), .Cells(c+ 12, 2)).Orientation = 0

       .Range(.Cells(c,2), .Cells(c+ 12, 2)).AddIndent = False

       .Range(.Cells(c,2), .Cells(c+ 12, 2)).IndentLevel = 0

       .Range(.Cells(c,2), .Cells(c+ 12, 2)).ShrinkToFit = True

       .Range(.Cells(c,2), .Cells(c+ 12, 2)).ReadingOrder = xlContext

       .Range(.Cells(c,2), .Cells(c+ 12, 2)).MergeCells = False

   End With

   With Sheet2.Cells(c, 2)  'Adjusting the label, right

       .Font.Name= "Arial" 'Font

       .Font.Size= 12     'Size

       .Font.Bold= True   'Alignment

       .HorizontalAlignment= xlCenter

       .VerticalAlignment= xlCenter

       .WrapText= False

       .Orientation= 0

       .AddIndent= False

       .IndentLevel= 0

       .ShrinkToFit= True

       .ReadingOrder= xlContext

       .MergeCells= False

   End With

   With Sheet2.Cells(c + 1, 2)            'Formatthe subtitle

       .HorizontalAlignment= xlCenter

       .VerticalAlignment= xlCenter

       .Font.Name= "Times New Roman"   'Font

       .Font.Size= 12                  'Size

   End With

  End If

 d =d + 1

 Next b

   If f = 13 And c > 1 Then

                      Sheet2.HPageBreaks.AddBefore:=Sheet2.Cells(c, 1)

   End If

 End If

Next a

   With Sheet2.PageSetup

       .LeftMargin= Application.InchesToPoints(0.5)

       .RightMargin= Application.InchesToPoints(0.5)

       .TopMargin= Application.InchesToPoints(0.5)

       .BottomMargin= Application.InchesToPoints(0.5)

       .HeaderMargin= Application.InchesToPoints(0.5)

       .FooterMargin= Application.InchesToPoints(0.5)

      .PrintHeadings = False

       .PrintGridlines= False

       .PrintNotes= False

       .CenterHorizontally= False

       .CenterVertically= False

       .Orientation= xlPortrait

       .Draft= False

       .PaperSize= xlPaperA4                  ' xlPaperA4:A4

       .FirstPageNumber= xlAutomatic

       .Order= xlDownThenOver

       .BlackAndWhite= False

       .Zoom= 100

       .FitToPagesWide= 1

       .FitToPagesTall= 1

       .PrintErrors= xlPrintErrorsDisplayed

       End With

Sheet2.PrintPreview