2015-10-21 115 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