Sub CopyData()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim i As Integer
    Dim R As Range
    Dim S As Range
    Dim lastRow1 As Integer
    Dim lastRow2 As Integer
    Dim RStart As Integer
    Dim REnd As Integer
    Dim SStart As Integer
    Dim SEnd As Integer

   '初始化工作表
    Set ws1 = ThisWorkbook.Worksheets("DEN基本信息")
    Set ws2 = ThisWorkbook.Worksheets("梳理")

   '获取原工作表中的R列
    lastRow1 = ws1.Cells(Rows.Count, "R").End(xlUp).Row
    Set R = ws1.Range("R:R")

   '获取目标工作表中的R列
    RStart = 2
    REnd = lastRow1 + 3
    Set R = ws2.Range("R:R")

   '判断目标工作表中的R列是否为字母
    For i = RStart To REnd
        If Not IsError(Application.Transpose(R.Value)) And R.Value Like "*PL*" Or R.Value Like "*PM*" Or R.Value Like "*PMB*" Or R.Value Like "*PT*" Or R.Value Like "*PIC*" Or R.Value Like "*PEL*" Or R.Value Like "*PSA*" Or R.Value Like "*PSD*" Or R.Value Like "*PQ*" Or R.Value Like "*PQC*" Or R.Value Like "*PMM*" Or R.Value Like "*ABCCS*" Or R.Value Like "*PPRO*" Then
           '复制原工作表中的R列到目标工作表中
            ws1.Range("R").Copy ws2.Range("R")

           '判断目标工作表中的R列是否连续几个字符为字母
            If R.Value Like "*PL*" Or R.Value Like "*PM*" Or R.Value Like "*PMB*" Or R.Value Like "*PT*" Or R.Value Like "*PIC*" Or R.Value Like "*PEL*" Or R.Value Like "*PSA*" Or R.Value Like "*PSD*" Or R.Value Like "*PQ*" Or R.Value Like "*PQC*" Or R.Value Like "*PMM*" Or R.Value Like "*ABCCS*" Or R.Value Like "*PPRO*" Then
               '复制目标工作表中的R列到新工作表中
                ws2.Range("S").Copy ws1.Range("R:R")

               '判断目标工作表中的R列是否连续几个字符为字母
                If R.Value Like "*PL*" Or R.Value Like "*PM*" Or R.Value Like "*PMB*" Or R.Value Like "*PT*" Or R.Value Like "*PIC*" Or R.Value Like "*PEL*" Or R.Value Like "*PSA*" Or R.Value Like "*PSD*" Or R.Value Like "*PQ*" Or R.Value Like "*PQC*" Or R.Value Like "*PMM*" Or R.Value Like "*ABCCS*" Or R.Value Like "*PPRO*" Then
                   '将目标工作表中的R列的字母字符插入到新工作表中
                    ws2.Range("S").Value = R.Value

                   '将目标工作表中的R列非字母字符插入到新工作表中
                    ws2.Range("S").Font.Bold = True
                    ws2.Range("S").AddRange R.Value
                End If
            End If
        End If
    Next i

   '更新工作表
    ws1.Range("R").Value = ""
    ws2.Range("S").Value = ""
End Sub