Xin được nhờ sự trợ giúp điền dữ liệu (4 người xem)

[Cát Lượng]

Em xin được nhờ điền dữ liệu từ sheet "Nhan_su" sang sheet "15"
anh/chị cho em hỏi có cách nào để điền dữ liệu nhanh không ạ?
em đang điền thủ công, mất thời gian (trong trường hợp dữ liệu nhiều)

 

[snow25]

Em xin được nhờ điền dữ liệu từ sheet "Nhan_su" sang sheet "15"
anh/chị cho em hỏi có cách nào để điền dữ liệu nhanh không ạ?
em đang điền thủ công, mất thời gian (trong trường hợp dữ liệu nhiều)
View attachment 212030View attachment 212031

VBA làm được.

 

[Cát Lượng]

VBA làm được.

VBA làm được.

Vâng, a giúp em được không ạ? em điền thủ công lâu quá!
cám ơn anh!

 

[snow25]

Vâng, a giúp em được không ạ? em điền thủ công lâu quá!
cám ơn anh!

Bạn chạy thử đoạn code này xem.

Sub dienten()
Dim arr, arr1, a As Long, i As Long, lr As Long
With Sheets("nhan_su")
     lr = .Range("B" & Rows.Count).End(xlUp).Row
     If lr < 2 Then Exit Sub
     arr = .Range("a1:C" & lr).Value
     ReDim arr1(1 To UBound(arr, 1) * 2, 1 To 2)
     For i = 2 To UBound(arr, 1)
         a = a + 1
         arr1(a, 1) = arr(i, 1)
         arr1(a, 2) = arr(1, 2) & arr(i, 2)
         a = a + 1
         arr1(a, 2) = arr(1, 3) & arr(i, 3)
     Next i
End With
With Sheets("15")
     lr = .Range("B" & Rows.Count).End(xlUp).Row
     If lr > 3 Then .Range("A4:b" & lr).ClearContents
     If a Then .Range("A4").Resize(a, 2).Value = arr1
End With
End Sub

 

[Cát Lượng]

Bạn chạy thử đoạn code này xem.

Sub dienten()
Dim arr, arr1, a As Long, i As Long, lr As Long
With Sheets("nhan_su")
     lr = .Range("B" & Rows.Count).End(xlUp).Row
     If lr < 2 Then Exit Sub
     arr = .Range("a1:C" & lr).Value
     ReDim arr1(1 To UBound(arr, 1) * 2, 1 To 2)
     For i = 2 To UBound(arr, 1)
         a = a + 1
         arr1(a, 1) = arr(i, 1)
         arr1(a, 2) = arr(1, 2) & arr(i, 2)
         a = a + 1
         arr1(a, 2) = arr(1, 3) & arr(i, 3)
     Next i
End With
With Sheets("15")
     lr = .Range("B" & Rows.Count).End(xlUp).Row
     If lr > 3 Then .Range("A4:b" & lr).ClearContents
     If a Then .Range("A4").Resize(a, 2).Value = arr1
End With
End Sub

Anh ơi,anh chỉnh lại giúp em chút, có thêm một dòng thứ tư, ban đầu em xóa nó đi.

 

[snow25]

Anh ơi,anh chỉnh lại giúp em chút, có thêm một dòng thứ tư, ban đầu em xóa nó đi.View attachment 212037

Bạn xem code này đúng không.

Sub dienten()
Dim arr, arr1, a As Long, i As Long, lr As Long
With Sheets("nhan_su")
     lr = .Range("B" & Rows.Count).End(xlUp).Row
     If lr < 4 Then Exit Sub
     arr = .Range("a3:C" & lr).Value
     ReDim arr1(1 To UBound(arr, 1) * 2, 1 To 2)
     For i = 2 To UBound(arr, 1)
         a = a + 1
         arr1(a, 1) = arr(i, 1)
         arr1(a, 2) = arr(1, 2) & arr(i, 2)
         a = a + 1
         arr1(a, 2) = arr(1, 3) & arr(i, 3)
     Next i
End With
With Sheets("15")
     lr = .Range("B" & Rows.Count).End(xlUp).Row
     If lr > 3 Then .Range("A4:b" & lr).ClearContents
     If a Then .Range("A4").Resize(a, 2).Value = arr1
End With
End Sub

 

[Cát Lượng]

Bạn xem code này đúng không.

Sub dienten()
Dim arr, arr1, a As Long, i As Long, lr As Long
With Sheets("nhan_su")
     lr = .Range("B" & Rows.Count).End(xlUp).Row
     If lr < 4 Then Exit Sub
     arr = .Range("a3:C" & lr).Value
     ReDim arr1(1 To UBound(arr, 1) * 2, 1 To 2)
     For i = 2 To UBound(arr, 1)
         a = a + 1
         arr1(a, 1) = arr(i, 1)
         arr1(a, 2) = arr(1, 2) & arr(i, 2)
         a = a + 1
         arr1(a, 2) = arr(1, 3) & arr(i, 3)
     Next i
End With
With Sheets("15")
     lr = .Range("B" & Rows.Count).End(xlUp).Row
     If lr > 3 Then .Range("A4:b" & lr).ClearContents
     If a Then .Range("A4").Resize(a, 2).Value = arr1
End With
End Sub

Anh ơi bị thừa dòng 4 và 5, nó lặp lại.
anh xem giúp em ạ!

 

[snow25]

Anh ơi bị thừa dòng 4 và 5, nó lặp lại.
anh xem giúp em ạ!View attachment 212039

Bạn xem code này.

Sub dienten()
Dim arr, arr1, a As Long, i As Long, lr As Long
With Sheets("nhan_su")
     lr = .Range("B" & Rows.Count).End(xlUp).Row
     If lr < 5 Then Exit Sub
     arr = .Range("a3:C" & lr).Value
     ReDim arr1(1 To UBound(arr, 1) * 2, 1 To 2)
     For i = 3 To UBound(arr, 1)
         a = a + 1
         arr1(a, 1) = arr(i, 1)
         arr1(a, 2) = arr(1, 2) & arr(i, 2)
         a = a + 1
         arr1(a, 2) = arr(1, 3) & arr(i, 3)
     Next i
End With
With Sheets("15")
     lr = .Range("B" & Rows.Count).End(xlUp).Row
     If lr > 3 Then .Range("A4:b" & lr).ClearContents
     If a Then .Range("A4").Resize(a, 2).Value = arr1
End With
End Sub

 

[Ba Tê]

Anh ơi bị thừa dòng 4 và 5, nó lặp lại.
anh xem giúp em ạ!

Ngộ quá! Sheet "nhan_su" có 2 dòng 4, 5 trùng nhau thì kết quả có 2 trường hợp trùng là đúng rồi!
Hay dữ liệu bắt đầu từ dòng 5?

 

[Cát Lượng]

Ngộ quá! Sheet "nhan_su" có 2 dòng 4, 5 trùng nhau thì kết quả có 2 trường hợp trùng là đúng rồi!
Hay dữ liệu bắt đầu từ dòng 5?

Dạ vâng, dữ liệu bắt đầu từ dòng thứ 5 ở sheet "Nhan_su" ạ!
Thầy xem giúp em ạ!

 

[Ba Tê]

Dạ vâng, dữ liệu bắt đầu từ dòng thứ 5 ở sheet "Nhan_su" ạ!
Thầy xem giúp em ạ!

Bài #8 đã chỉnh rồi kìa!
Nếu tôi viết thì thế này:

Public Sub sGpe()
Dim sArr(), dArr() As String, I As Long, K As Long, R As Long, STT As Long, VTri As String, HTen As String
With Sheets("nhan_su")
    If .Range("C50000").End(xlUp).Row < 5 Then Exit Sub
    sArr = .Range("B5", .Range("C50000").End(xlUp)).Value
    VTri = .Range("B3").Value
    HTen = .Range("C3").Value
    R = UBound(sArr)
End With
ReDim dArr(1 To R * 2, 1 To 2)
For I = 1 To R
    If sArr(I, 1) <> Empty Then
        K = K + 1: STT = STT + 1
        dArr(K, 1) = STT & "."
        dArr(K, 2) = VTri & sArr(I, 1)
        K = K + 1
        dArr(K, 2) = HTen & sArr(I, 2)
    End If
Next I
With Sheets("15")
    .Range("A4").Resize(1000, 2).ClearContents
    .Range("A4").Resize(K, 2) = dArr
End With
End Sub

 

[Cát Lượng]

Bài #8 đã chỉnh rồi kìa!
Nếu tôi viết thì thế này:

Public Sub sGpe()
Dim sArr(), dArr() As String, I As Long, K As Long, R As Long, STT As Long, VTri As String, HTen As String
With Sheets("nhan_su")
    If .Range("C50000").End(xlUp).Row < 5 Then Exit Sub
    sArr = .Range("B5", .Range("C50000").End(xlUp)).Value
    VTri = .Range("B3").Value
    HTen = .Range("C3").Value
    R = UBound(sArr)
End With
ReDim dArr(1 To R * 2, 1 To 2)
For I = 1 To R
    If sArr(I, 1) <> Empty Then
        K = K + 1: STT = STT + 1
        dArr(K, 1) = STT & "."
        dArr(K, 2) = VTri & sArr(I, 1)
        K = K + 1
        dArr(K, 2) = HTen & sArr(I, 2)
    End If
Next I
With Sheets("15")
    .Range("A4").Resize(1000, 2).ClearContents
    .Range("A4").Resize(K, 2) = dArr
End With
End Sub

Em cám ơn Thầy!

Bài đã được tự động gộp: 11/2/19

Bạn xem code này.

Sub dienten()
Dim arr, arr1, a As Long, i As Long, lr As Long
With Sheets("nhan_su")
     lr = .Range("B" & Rows.Count).End(xlUp).Row
     If lr < 5 Then Exit Sub
     arr = .Range("a3:C" & lr).Value
     ReDim arr1(1 To UBound(arr, 1) * 2, 1 To 2)
     For i = 3 To UBound(arr, 1)
         a = a + 1
         arr1(a, 1) = arr(i, 1)
         arr1(a, 2) = arr(1, 2) & arr(i, 2)
         a = a + 1
         arr1(a, 2) = arr(1, 3) & arr(i, 3)
     Next i
End With
With Sheets("15")
     lr = .Range("B" & Rows.Count).End(xlUp).Row
     If lr > 3 Then .Range("A4:b" & lr).ClearContents
     If a Then .Range("A4").Resize(a, 2).Value = arr1
End With
End Sub

Cám ơn anh ạ!