ghép nối ký tự theo dữ liệu cho sẵn (2 người xem)

[caonguyen89]

xin nhờ các anh chị

em có 1 biểu mẫu như file. hiện tại muốn sử dụng code VBA để ghép nối 3 cột hoặc nhiều hơn.

kết quả cần như sheets " kết quả "

 

[snow25]

xin nhờ các anh chị

em có 1 biểu mẫu như file. hiện tại muốn sử dụng code VBA để ghép nối 3 cột hoặc nhiều hơn.

kết quả cần như sheets " kết quả "

Bạn thử code này.

Sub linhtinh()
     Dim arr, arr1, i As Long, j As Long, a As Long
     With Sheets("DAta")
          arr = .Range("B3:D3").Value
          ReDim arr1(1 To 10000, 1 To 1)
          For i = 1 To arr(1, 2)
              For j = 1 To arr(1, 3)
                  a = a + 1
                  arr1(a, 1) = arr(1, 1) & "-" & i & "-" & j
               Next j
          Next i
          .Range("F3").Resize(a).Value = arr1
     End With
End Sub

 

[caonguyen89]

Bạn thử code này.

Sub linhtinh()
     Dim arr, arr1, i As Long, j As Long, a As Long
     With Sheets("DAta")
          arr = .Range("B3:D3").Value
          ReDim arr1(1 To 10000, 1 To 1)
          For i = 1 To arr(1, 2)
              For j = 1 To arr(1, 3)
                  a = a + 1
                  arr1(a, 1) = arr(1, 1) & "-" & i & "-" & j
               Next j
          Next i
          .Range("F3").Resize(a).Value = arr1
     End With
End Sub

cám ơn bạn,
nhưng với code này chỉ tạo được dữ liệu với 1 dòng, mình muốn tạo thêm điều kiện là 2 hoặc nhiều hơn sẽ không được đúng không. thêm nữa với vùng điều kiện " Layer " và " Location " có giá trị nhỏ hơn 10 thì cần bổ xung số "0" đằng trước. ví dụ A-01-01

 

[Phuocam]

Thử code này:

Public Sub test()
Dim i As Long
Dim ii As Long
Dim iii As Long
Dim lr As Long
Dim sArr, dArr
Dim u As Long
Dim k As Long
With Sheets("data")
    lr = .Range("B" & .Rows.Count).End(xlUp).Row
    sArr = .Range("B3:D" & lr).Value
    lr = UBound(sArr, 1)
End With
    For i = 1 To lr
       u = u + (sArr(i, 2) * sArr(i, 3))
    Next i
If u >= Rows.Count Then
    MsgBox " So qua lon"
    Exit Sub
End If
ReDim dArr(1 To u, 1 To 1)
    For i = 1 To lr
        For ii = 1 To sArr(i, 2)
            For iii = 1 To sArr(i, 3)
                k = k + 1
                dArr(k, 1) = sArr(i, 1) & "-" & Format(ii, "00") & "-" & Format(iii, "00")
            Next iii
         Next ii
    Next i
If k > 0 Then Sheets("KetQua").Range("B2").Resize(k, 1) = dArr
End Sub

 

[caonguyen89]

Thử code này:

Public Sub test()
Dim i As Long
Dim ii As Long
Dim iii As Long
Dim lr As Long
Dim sArr, dArr
Dim u As Long
Dim k As Long
With Sheets("data")
    lr = .Range("B" & .Rows.Count).End(xlUp).Row
    sArr = .Range("B3:D" & lr).Value
    lr = UBound(sArr, 1)
End With
    For i = 1 To lr
       u = u + (sArr(i, 2) * sArr(i, 3))
    Next i
If u >= Rows.Count Then
    MsgBox " So qua lon"
    Exit Sub
End If
ReDim dArr(1 To u, 1 To 1)
    For i = 1 To lr
        For ii = 1 To sArr(i, 2)
            For iii = 1 To sArr(i, 3)
                k = k + 1
                dArr(k, 1) = sArr(i, 1) & "-" & Format(ii, "00") & "-" & Format(iii, "00")
            Next iii
         Next ii
    Next i
If k > 0 Then Sheets("KetQua").Range("B2").Resize(k, 1) = dArr
End Sub

mình thử nhưng code không chạy,
If k > 0 Then Sheets("KetQua").Range("B2").Resize(k, 1) = dArr đoạn này có lỗi

 

[CHAOQUAY]

@caonguyen89
Thử đổi tên sheet "kết quả" thành KetQua xem sao

 

[caonguyen89]

hen Sheets("K

@caonguyen89
Thử đổi tên sheet "kết quả" thành KetQua xem sao

mình quên mất không sử dụng tiếng việt

mình đã chỉnh sửa lại đoạn code này để chạy tại sheet "data" rồi
If k > 0 Then Range("f2").Resize(k, 1) = dArr