vba 同一个excel工作表，sheet之间同列头内容的复制

vba 同一个excel工作表，sheet之间同列头内容的复制

人工核对编程，每一列写一条代码，例如，这个语句把sheet1表的A列拷贝到sheet2表的A列：
Sheets("sheet1").Range("A:A").Copy Sheets("sheet2").Range("A:A")

下面的语句同时拷屏A、B两列：
Sheets("sheet1").Range("A:B").Copy Sheets("sheet2").Range("A:B")

下面的语句把sheet1表的C列（单位名称）拷贝到sheet2表的D列：
Sheets("sheet1").Range("C:C").Copy Sheets("sheet2").Range("D:D")追问人工核对太麻烦啊，数据量大这个还是不好操作哦追答完全符合你的要求，测试通过的代码：
Sub xxx()
    Dim i, j
    For i = 1 To Sheet2.UsedRange.Columns.Count
        For j = 1 To Sheet1.UsedRange.Columns.Count
            If Sheet1.Cells(1, i) = Sheet2.Cells(1, j) Then
                Sheet1.Columns(i).Copy Sheet2.Columns(j)
                Exit For
            End If
        Next j
    Next i
End Sub追问可以了，太谢谢了！追答可用就行。麻烦点一下“采纳”～追问　　好像还是不行，我的实际例子是

　　　　结果是这样麻烦你在帮我看看
追答不行是什么意思？能否拷屏，你的代码，执行的状态。

Sub findred()
Set xxx = Sheet1.UsedRange
For t1 = 1 To xxx.Rows.Count
For t2 = 1 To xxx.Columns.Count
If xxx(t1, t2).Font.ColorIndex = 3 Then
r = r + 1
Sheet2.Cells(r, 1).Resize(1, xxx.Columns.Count) = xxx.Rows(t1).Value
Exit For
End If
Next
Next
End Sub
--------------------------------------------------
根据补充, 再写以下一段程序:
Sub findempty()
Set xxx = Sheet1.[A3:A10000]
Set yy = Sheet2.[A3]
For Each xx In xxx
If Not IsEmpty(xx) Then
yy.Offset(r, 0) = xx
yy.Offset(r, 1) = xx.Offset(0, 3)
r = r + 1
End If
Next
End Sub
此程序差不多是VBA最基本及最低程度的代码, 亦容易明白及修改单元格的范围

如以上回答内容为低俗、色情、不良、暴力、侵权、涉及违法等信息，可以点下面链接进行举报！

点此我要举报以上问答信息