如何在excel vba中保留格式复制

Posted 2021-05-04

嘿家伙，我有下一个代码：

Option Explicit
Option Base 1
Option Compare Text

Dim M(), fm&
Dim R, fr&, fu%, uf&, fila&
Dim Q&, i%, j%, arr
Dim fecha&, DD%, MM%, YY%
Dim G%, GR%, GP%, GF%, GC%, GE%, GRC%, GPC%, GFC%, COLUMNA%, QG$


Sub OBTENER·NUM·REG()

Dim H As Worksheet
Dim S As Worksheet
fm = 0
arr = Array("Gener", "Febrer", "Març", "Abril", "Maig", "Juny", "Juliol", _
             "Agost", "Setembre", "Octubre", "Novembre", "Desembre")


Q = 0
 For Each H In ThisWorkbook.Worksheets '(GetParcNames)


   If H.Name <> "Result" Then
      With H
           fu = .Range("A:A").Find(H.Name).Row + 1
           uf = .Range("A" & Rows.Count).End(xlUp).Row

            Q = Q + (uf - fu + 1) * 31
          For i = 1 To 12
            If arr(i) = .Range("a2") Then
               YY = Year(Now)
               MM = Month(CDate("01/" & i & "/" & YY))
               Exit For
            End If
          Next
      End With
   End If
Next

ReDim M(Q, 6 + 6)
For Each H In Worksheets
   If H.Name <> "Result" Then
      With H
         fu = .Range("A:A").Find(H.Name).Row + 1
         uf = .Range("A" & Rows.Count).End(xlUp).Row
         Set R = .Range(.Cells(fu, 1), .Cells(uf, 129))
         For fr = 1 To R.Rows.Count
            fila = R(fr, 1).Row
            If Len(Trim(R(fr, 1))) > 0 Then
               For i = 6 To 126 Step 4
                  For j = i To i + 3
                     QG = .Cells(fila, j)
                     If Len(Trim(QG)) = 0 Then Exit For
                     Select Case QG
                        Case "G":        G = G + 1:  COLUMNA = 4: GoSub REGISTRAR·DATO: Exit For
                        Case "GR":     GR = GR + 1:  COLUMNA = 5: GoSub REGISTRAR·DATO: Exit For
                        Case "GP":     GP = GP + 1:  COLUMNA = 6: GoSub REGISTRAR·DATO: Exit For
                        Case "GF":     GF = GF + 1:  COLUMNA = 7: GoSub REGISTRAR·DATO: Exit For
                        Case "GC":     GC = GC + 1:  COLUMNA = 8: GoSub REGISTRAR·DATO: Exit For
                        Case "GE":     GE = GE + 1:  COLUMNA = 9: GoSub REGISTRAR·DATO: Exit For
                        Case "GRC":  GRC = GRC + 1: COLUMNA = 10: GoSub REGISTRAR·DATO: Exit For
                        Case "GPC":  GPC = GPC + 1: COLUMNA = 11: GoSub REGISTRAR·DATO: Exit For
                        Case "GFC":  GFC = GFC + 1: COLUMNA = 12: GoSub REGISTRAR·DATO: Exit For
                     End Select
                  Next
               Next
            End If
         Next
      End With
   End If
Next

SACAR·DATOS
ORDENAR·DATOS

Exit Sub

REGISTRAR·DATO:

'Stop
fm = fm + 1
M(fm, 1) = H.Cells(fila, 1)
M(fm, 2) = H.Name

 M(fm, 3) = CDbl(CDate(H.Cells(4, i) & "/" & MM & "/" & YY))
M(fm, COLUMNA) = 1




Return

sale:
Sheets(H.Name).Select
MsgBox "En general, este error está en la celda A6: el nombre que aquí figura no concuerda con el de la hoja"
Stop
Exit Sub

End Sub
Private Sub SACAR·DATOS()
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Result").Select

On Error GoTo 0
Cells.ClearContents
Range("A1").Resize(, 13) = Array("NOM", "PARC", "DATA", "G", "GR", "GP", "GF", "GC", "GE", "GRC", "GPC", "GFC", "PERTENEIX A")
Range("A1").Resize(, 13).Font.Bold = True

MsgBox "Continuar ..."
Application.ScreenUpdating = False
Range("A2").Resize(fm, 13) = M

Range("A:IV").Columns.AutoFit
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Cells(1, 1).Select

ActiveWindow.ScrollRow = ActiveCell.Row
End Sub


Public Function GetParcNames() As Variant

    GetParcNames = Array("Calvia", "Inca", "Manacor", "Soller", "Alcudia", "Felanitx", "Arta", "Llucmajors                                       ") 'spelling and accents must be same for sheet names and in sheet as are spelt here

End Function





Private Sub ORDENAR·DATOS()
Dim R As Range, fr&, cr%
   Set R = Range("a1").CurrentRegion
Dim Q&
   Q = R.Rows.Count
    ActiveWorkbook.Worksheets("Result").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Result").Sort.SortFields.Add Key:=Range("B2:B" & Q), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Result").Sort.SortFields.Add Key:=Range("A2:A" & Q), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Result").Sort.SortFields.Add Key:=Range("C2:C" & Q), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Result").Sort
        .SetRange Range("A1:F" & Q)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

For fr = R.Rows.Count To 2 Step -1
   If R(fr, 1) & R(fr, 2) = R(fr - 1, 1) & R(fr - 1, 2) Then
      R(fr, 1) = ""
      R(fr, 2) = ""
      fr = fr + 1
   End If
Next

For cr = 4 To R.Columns.Count
   R(1, cr).ColumnWidth = 5
Next

End Sub

它的作品。但是，原始工作表中复制的数据具有Font Bold的任何行。 Howewer，当我在“结果”中执行我的脚本时，出现那些字体粗体而没有字体粗体的单词。

我读的解决方案是粘贴：= xlPasteFormats但我不知道在哪里应用它..有什么建议吗？