Chèn thêm cột dữ liệu vào bảng tính (1 người xem)

[sep_hatxel]

Mình có vấn đề sau mong GPE giúp đỡ. Bảng dữ liệu ở sheet1, cột B có dữ liệu. Mình cần copy cột B rồi chèn dữ liệu cột B này thêm vào trước tất cả những cột có kí hiệu là 2 (hoặc cột có kí hiệu nào đó do mình chỉ định). Mình làm mẫu minh hoạ kết quả chèn xuất sang ở sheet2. Mong các bạn xem giúp. Xin cảm ơn rất nhiều!

 

[Let'GâuGâu]

Mình có vấn đề sau mong GPE giúp đỡ. Bảng dữ liệu ở sheet1, cột B có dữ liệu. Mình cần copy cột B rồi chèn dữ liệu cột B này thêm vào trước tất cả những cột có kí hiệu là 2 (hoặc cột có kí hiệu nào đó do mình chỉ định). Mình làm mẫu minh hoạ kết quả chèn xuất sang ở sheet2. Mong các bạn xem giúp. Xin cảm ơn rất nhiều!

thử đoạn code sau

Sub Macro1()
Application.ScreenUpdating = False
Dim c As Range
Sheet1.Copy After:=Sheets(Sheets.Count)
myNum = Application.InputBox("Enter a number")
With [C3:AF3]
    Set c = .Find(What:=myNum, After:=[c3], LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
    If Not c Is Nothing Then
        firstaddress = c.Offset(, 1).Address
         c.EntireColumn.Insert
         c.Offset(1, -1).Resize([a1000].End(3).Row - 3).Value = Range([b4], [b1000].End(3)).Value
        Do
            c.Value = myNum
            Set c = .FindNext(c)
            If Not c Is Nothing And c.Address <> firstaddress Then
                c.EntireColumn.Insert
                c.Offset(1, -1).Resize([a1000].End(3).Row - 3).Value = Range([b4], [b1000].End(3)).Value
            End If
        Loop While Not c Is Nothing And c.Address <> firstaddress
    End If
End With

Application.ScreenUpdating = True

End Sub

 

[sep_hatxel]

thử đoạn code sau

Sub Macro1()
Application.ScreenUpdating = False
Dim c As Range
Sheet1.Copy After:=Sheets(Sheets.Count)
myNum = Application.InputBox("Enter a number")
With [C3:AF3]
    Set c = .Find(What:=myNum, After:=[c3], LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
    If Not c Is Nothing Then
        firstaddress = c.Offset(, 1).Address
         c.EntireColumn.Insert
         c.Offset(1, -1).Resize([a1000].End(3).Row - 3).Value = Range([b4], [b1000].End(3)).Value
        Do
            c.Value = myNum
            Set c = .FindNext(c)
            If Not c Is Nothing And c.Address <> firstaddress Then
                c.EntireColumn.Insert
                c.Offset(1, -1).Resize([a1000].End(3).Row - 3).Value = Range([b4], [b1000].End(3)).Value
            End If
        Loop While Not c Is Nothing And c.Address <> firstaddress
    End If
End With

Application.ScreenUpdating = True

End Sub

Cảm ơn bạn rất nhiều!

 

[TrungChinhs]

Bạn thử củ mì này xem sao. Bạn nhập Điều kiện vào A2 trước khi chạy code

Sub xxx()
    On Error Resume Next
    RngEnd = [c3].End(2).Column - 2
    [b2].Resize(, RngEnd + 1) = "=Column()"
    For Each cls In [c3].Resize(, RngEnd)
        If cls = [a2] Then
            [b2] = cls(0, 0)
            [b2:b100].Copy [b2].End(2)(1, 2)
        End If
    Next
    Columns("c:az").Sort [c2], 1, , , , , 2
    [b2].EntireColumn.Delete
    Rows("2:2").ClearContents
End Sub