剪切并粘贴特殊字体数据，将粘贴到Excel中不同列中的其他数据的数据alignment

寻找一个可以将数据复制到列A中的数据的macros

我有我的原始数据： 原始数据

然后我有一个macros，从斜体 B到C复制所有的数据

Sub copy_Italic() 'Narrations in Italics Copy Dim LastRow As Long, x As Long, y As Long, txt1 As String, txt As String LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row For x = 2 To LastRow txt1 = "" txt = Cells(x, 2) If txt <> "" Then For y = Len(txt) To 1 Step -1 If Cells(x, 2).Characters(Start:=y, Length:=1).Font.Italic Then txt1 = Cells(x, 2).Characters(Start:=y, Length:=1).Text & txt1 End If Next y Cells(x, 3) = txt1 End If End Sub 

所以我需要一个macros来select列C中的叙述数据，然后将它们alignment到列A中的可用数据，并select“input…”文本并将其粘贴到列D上，同时alignment列A，然后删除不需要的行查看结果： 期望的结果

谢谢。 随意提供上述macros的改进！

Answer 1

请使用下面的代码。 如果将遍历您的数据并将所有italic values添加到相应行中的C列。 然后它将过滤"entered by"字并将该值添加到列D （也在相应的行）。 之后，它将删除B列中所有用斜体表示的行。

 Sub copy_Italic() LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row For x = 1 To LastRow If Range("A" & x) <> 0 Then Row = x txt = Cells(x, 2) If txt <> "" Then For y = Len(txt) To 1 Step -1 If Cells(x, 2).Characters(Start:=y, Length:=1).Font.Italic Then txt1 = Cells(x, 2).Characters(Start:=y, Length:=1).Text & txt1 End If Next y If InStr(LCase(txt1), "entered by") = 1 Then Cells(Row, 4) = txt1 Else Debug.Print txtl For Z = 1 To 10 If Range("c" & Row + Z - 1).Value = "" Then Cells(Row + Z - 1, 3) = txt1 GoTo Tu: End If Next Z End If Tu: End If Else txt1 = "" txt = Cells(x, 2) If txt <> "" Then For y = Len(txt) To 1 Step -1 If Cells(x, 2).Characters(Start:=y, Length:=1).Font.Italic Then txt1 = Cells(x, 2).Characters(Start:=y, Length:=1).Text & txt1 End If Next y If InStr(LCase(txt1), "entered by") = 1 Then Cells(Row, 4) = txt1 Else Debug.Print txtl For Z = 1 To 10 If Range("c" & Row + Z - 1).Value = "" Then Cells(Row + Z - 1, 3) = txt1 GoTo ovdje: End If Next Z End If ovdje: End If End If Next x For i = LastRow To 1 Step -1 If Range("b" & i).Font.Italic = True Then Range("B" & i).EntireRow.Delete End If Next i End Sub