Hỗ trợ thay đổi một dòng thành ba dòng

[Nguyenhoangphong0902]

Em chào anh chị, em có bài thực tế như sau, em có cột dữ liệu là A và B, em cần chuyển sang cột R,S,T.
dữ liệu cột A, B sẽ tăng lên 3 lần. Còn cột T thì ý nghĩa là 1 mã sẽ có 3 trường: 1000, 4000, 1999.
Bài này em ví dụ 4 mã, còn thực thực tế của em là rất nhiều mã, vì thế mong muốn của em là được code bằng mảng(Array).
(À bài này bắt đầu từ dòng thứ 2 nhé anh chị, dòng 1 là mặc định rồi.)
Em cảm ơn anh chị nhiều.

 

[befaint]

Copy vùng ban đầu rồi dán 2 phát, kế đó sort 1 cái là xong.

 

[Nguyenhoangphong0902]

Copy vùng ban đầu rồi dán 2 phát, kế đó sort 1 cái là xong.

Làm kiểu này thì đâu còn gì tự động đâu anh, với lại dữ liệu cột C,D,E....có sẵn nên không thể làm sort được. Và em mong muốn có code rồi em chỉnh sửa cho nhiều trường hợp khác. Vì có nhiều trường hợp em phải tăng 5-10, 20 dòng chẳng hạn. Em có thể đọc code với chỉnh sửa code, nhưng lại không thể viết code được hic hic...

 

[befaint]

với lại dữ liệu cột C,D,E....có sẵn nên không thể làm sort được

Chưa biết làm rồi. Mình chỉ sort cột A mà thôi.

Làm kiểu này thì đâu còn gì tự động đâu anh,

Siêu siêu tự động nhé.

 

[Nguyenhoangphong0902]

Em có 1 đoạn code này cũng phục vụ được nhu cầu của em. Nhưng khổ cái nó làm 2 sheet. Mà mong muốn của em chỉ là trên 1 sheet thôi. Anh có thể sửa lại giúp em được ko?

Sheet2.Range("A2:CF10000").ClearContents
Dim lr1 As Double, lc1 As Double
lr1 = Sheet1.Range("A1000000").End(xlUp).Row
lc1 = Sheet1.Range("XFD2").End(xlToLeft).Column
Dim lr2 As Double
lr2 = Sheet2.Range("A1000000").End(xlUp).Row
Dim arr1
arr1 = Sheet1.Range(Sheet1.Cells(2, 1), Sheet1.Cells(lr1, lc1)).Value
Dim arr2
ReDim arr2(1 To UBound(arr1, 1) * 3, 1 To UBound(arr1, 2))
For i = 1 To UBound(arr1, 1)
For j = 1 To UBound(arr1, 2)
For k = 1 To 3
arr2((i - 1) * 3 + k, j) = arr1(i, j)
Next k
Next j
Next i
Sheet2.Range(Sheet2.Cells(lr2 + 1, 1), Sheet2.Cells(lr2 + UBound(arr1, 1) * 3, lc1)).Value = arr2

 

[befaint]

Code viết 1 vòng lặp thôi. Thấy khai báo Double gớm quá.

 

[Nguyenhoangphong0902]

Code viết 1 vòng lặp thôi. Thấy khai báo Double gớm quá.

Code này người khác viết mà anh. Thường thì em sẽ thêm biến input box vào. thay tất cả số 3 thành Inputbox rồi, nhập 5 thành 5 dòng, nhập 10 thì nó thành 10 dòng.

 

[Nguyenhoangphong0902]

Bài này em đã viết được 1 sub bình thường thì nó cũng làm được nhưng không biết sao nó chậm, khi dữ liệu lớn.
Nên nếu anh chị nào viết được bằng mảng thì viết giúp em. Em cảm ơn

Sub change_gia()
Dim dong_cuoi_1 As Long
Dim k As Long

dong_cuoi_1 = Sheet1.Range("A" & Rows.Count).End(xlUp).Row

k = dong_cuoi_1 - 1
Sheet1.Range("A2:B" & dong_cuoi_1).Copy
Sheet1.Range("R2").PasteSpecial xlPasteValues
Sheet1.Range("R" & (k + 2)).PasteSpecial xlPasteValues
Sheet1.Range("R" & (k + k + 2)).PasteSpecial xlPasteValues

Sheet1.Range("T2:T" & k + 1) = 1000
Sheet1.Range("T" & k + 2 & ":T" & k * 2 + 1) = 4000
Sheet1.Range("T" & k * 2 + 2 & ":T" & k * 3 + 1) = 1999

End Sub

 

[bebo021999]

Làm đại, sai bỏ.

Sub test()
Dim W, M, G As Range
Dim i As Long
Set W = Range("C2:C" & Range("C2").End(xlDown).Row)
Set M = Range("A2:A" & Range("A2").End(xlDown).Row)
Set G = Range("B2:B" & Range("B2").End(xlDown).Row)
Range("R2:T1000").ClearContents
For i = 1 To W.Count * M.Count
Range("R" & i + 1).Value = M(Int((i - 1) / W.Count) + 1).Value
Range("S" & i + 1).Value = G(Int((i - 1) / W.Count) + 1).Value
Range("T" & i + 1).Value = W((i - 1) Mod W.Count + 1).Value
Next
End Sub

 

[Nguyenhoangphong0902]

Em cảm ơn bác bebo021999 nhiều

 

[HUONGHCKT]

Em chào anh chị, em có bài thực tế như sau, em có cột dữ liệu là A và B, em cần chuyển sang cột R,S,T.
dữ liệu cột A, B sẽ tăng lên 3 lần. Còn cột T thì ý nghĩa là 1 mã sẽ có 3 trường: 1000, 4000, 1999.
Bài này em ví dụ 4 mã, còn thực thực tế của em là rất nhiều mã, vì thế mong muốn của em là được code bằng mảng(Array).
(À bài này bắt đầu từ dòng thứ 2 nhé anh chị, dòng 1 là mặc định rồi.)
Em cảm ơn anh chị nhiều.

Góp vui,thêm 1 code nữa cho bạn lựa chọn.
Kết quả đang để ở ô V2.

Sub GIA_XYZ()
Dim i&, Lr&, t&
Dim Arr(), KQ(), gia
Dim Sh As Worksheet
Set Sh = Sheets("Sheet1")
Lr = Sh.Cells(Rows.Count, 2).End(xlUp).Row
Arr = Sh.Range("A2:B" & Lr).Value
ReDim KQ(1 To UBound(Arr) * 3, 1 To 3)
gia = Array(, 1000, 4000, 1990)
For i = 1 To UBound(Arr)
    For j = 1 To 3
        t = t + 1
        KQ(t, 1) = Arr(i, 1)
        KQ(t, 2) = Arr(i, 2)
        KQ(t, 3) = gia(j)
    Next j
Next i
Sh.Range("V2").Resize(t, 3) = KQ
MsgBox " Xong", vbInformation, "THÔNG BÁO"
End Sub

 

[Maika8008]

Chơi lớn luôn chứ không sai bỏ hay góp vui chi hết...
Ну, погоди! Nu, pogozi! Nu, pa-gơ-di...

 

[SA_DQ]

Thông báo Chuyển hướng

www.google.com.vn

 

[BuiQuangThuan]

@Nguyenhoangphong0902 Thử 1 cách khác

Sub ABC()
    Dim Rng As Range, WERKS, iR&, WF As Object
    Set WF = Application.WorksheetFunction
    WERKS = Array("1000", "4000", "9999")
    With Sheet1
        .Range("R2:T1000").ClearContents
        For Each Rng In .Range("A2:A" & .Range("A" & Rows.Count).End(3).Row)
            iR = .Range("R" & Rows.Count).End(3).Row + 1
            .Range("R" & iR).Resize(3, 2).Value = Rng.Resize(, 2).Value
            .Range("T" & iR).Resize(3).Value = WF.Transpose(WERKS)
        Next
    End With
End Sub