2015-10-21 107 views
0

我试图写一个宏,它根据列标题更改单元格的格式。根据列标题格式化列

Header_2需要为PROPER情况下, Header_3需要为UPPER情况, 所有列标题需要为UPPER情况。

我已经简化了这个例子,但实际上我有80列,平均有3000行,列中有空格 - 因此宏需要运行而我没有选择或指定范围。

下面是我到目前为止的代码 - 尽管我不断收到“不匹配”的错误(不知道如何解决它)

预先感谢任何见解或帮助你能够提供!

这里是我的数据:

enter image description here

Sub Proper_text() 



Dim i As Integer 


For i = 1 To 80 
    If Cells(1, i).Value = "HEADER_2" Then 

     For Each cell In Columns(i) 

      If Not IsEmpty(cell) Then 

       cell.Value = WorksheetFunction.Proper(cell.Value) 


      End If 

     Next cell 

    End If 
Next i 



End Sub 

回答

0

试试这个

Public Sub Proper_text() 
    Dim ws As Worksheet, ur As Range, fr As Long, lr As Long, lc As Long, x As Range 

    Set ws = ActiveSheet 
    Set ur = ws.UsedRange 
    fr = ur.Row 
    lr = ur.Row + ur.Rows.Count - 1 
    lc = ur.Column + ur.Columns.Count - 1 

    Application.ScreenUpdating = False 

    For Each x In ur.Range(ur.Cells(fr, ur.Column), ur.Cells(fr, lc)) 
     x.Offset(, lc).Formula = "=UPPER(" & x.Address(False, False) & ")" 
    Next 

    For Each x In ur.Range(ur.Cells(fr + 1, ur.Column), ur.Cells(fr + 1, lc)) 

     If UCase(x.Offset(-1).Value2) = "HEADER_2" Then 
      x.Offset(, lc).Formula = "=PROPER(" & x.Address(False, False) & ")" 
     Else 
      x.Offset(, lc).Formula = "=UPPER(" & x.Address(False, False) & ")" 
     End If 

    Next 

    Set x = ws.Range(ws.Cells(fr + 1, lc + 1), ur.Cells(fr + 1, lc * 2)) 
    x.AutoFill Destination:=ur.Range(ur.Cells(fr + 1, lc + 1), ur.Cells(lr, lc * 2)) 

    ur.Range(ur.Cells(fr, lc + 1), ur.Cells(lr, lc * 2)).Copy 
    ur.Range(ur.Cells(fr, ur.Column), ur.Cells(lr, lc)).PasteSpecial Paste:=xlPasteValues 

    ur.Range(ur.Cells(fr, lc + 1), ur.Cells(fr, lc * 2)).EntireColumn.Delete 

    Application.ScreenUpdating = True 
    ws.Cells(1).Select 
End Sub 

结果

Before:          After: 

HEAser_1 HEADer_2 heaDER_3   HEASER_1 HEADER_2 HEADER_3 
-------- -------- --------   -------- -------- -------- 
    1  sTphn  pRCELL    1   Stphn  PRCELL 
    2  ADIL  mlr     2   Adil  MLR 
    3  Mlling  sNN     3   Mlling  SNN 
    4  Rosemary Irvine    4   Rosemary IRVINE 
    5          5 
    6  JIA   pAn     6   Jia   PAN 
    7  MAJID  doost    7   Majid  DOOST 
    8  WILLIAM  smith    8   William  SMITH 
    9          9 
    10  VIssUT  domklAng    10   Vissut  DOMKLANG 
    11  RoDNy  mCdermid    11   Rodny  MCDERMID 
    12  RoBrt  pACker    12   Robrt  PACKER 
    13  PAUL  retz     13   Paul  RETZ 
    14  TRoY  mACpherson   14   Troy  MACPHERSON 
    15  CATHRYN  stAfford    15   Cathryn  STAFFORD