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

Liên hệ QC
Cát Lượng

Cát Lượng

Thành viên tiêu biểu
Tham gia
14/11/18
Bài viết
403
Được thích
66
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)
1.png2.png
 

File đính kèm

  • bi.xls
    55 KB · Đọc: 9
Cát Lượng đã viết:
Vâng, a giúp em được không ạ? em điền thủ công lâu quá!
cám ơn anh!
Nhấp chuột vào đây để mở rộng...
Bạn chạy thử đoạn code này xem.
Mã: 
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
 

File đính kèm

  • Book1.xlsm
    17.2 KB · Đọc: 7
snow25 đã viết:
Bạn chạy thử đoạn code này xem.
Mã: 
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
Nhấp chuột vào đây để mở rộng...
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.145.png
 

File đính kèm

  • sua.xlsm
    18.3 KB · Đọc: 9
Cát Lượng đã viết:
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
Nhấp chuột vào đây để mở rộng...
Bạn xem code này đúng không.
Mã: 
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
 
snow25 đã viết:
Bạn xem code này đúng không.
Mã: 
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
Nhấp chuột vào đây để mở rộng...
Anh ơi bị thừa dòng 4 và 5, nó lặp lại.
anh xem giúp em ạ!4422.png
 
Cát Lượng đã viết:
Anh ơi bị thừa dòng 4 và 5, nó lặp lại.
anh xem giúp em ạ!View attachment 212039
Nhấp chuột vào đây để mở rộng...
Bạn xem code này.
Mã: 
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át Lượng đã viết:
Dạ vâng, dữ liệu bắt đầu từ dòng thứ 5 ở sheet "Nhan_su" ạ!
Thầy xem giúp em ạ!
Nhấp chuột vào đây để mở rộng...
Bài #8 đã chỉnh rồi kìa!
Nếu tôi viết thì thế này:
PHP: 
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
 
Ba Tê đã viết:
Bài #8 đã chỉnh rồi kìa!
Nếu tôi viết thì thế này:
PHP: 
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
Nhấp chuột vào đây để mở rộng...
Em cám ơn Thầy!
Bài đã được tự động gộp:

snow25 đã viết:
Bạn xem code này.
Mã: 
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
Nhấp chuột vào đây để mở rộng...
Cám ơn anh ạ!
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

C
Outstanding Сasual Dating - Real-life Females
Trả lời
0
Đọc
16
chua123
C
phanmoi688
[Xin nhờ giúp đỡ] Cách đối chiếu dữ liệu giữa hai biểu
    • Thích
Trả lời
13
Đọc
153
VetMini
V
V
Giúp công thức cộng tổng cột SỐ lượng theo cột STT nếu trùng lấy dòng nằm trên
Trả lời
14
Đọc
455
VetMini
V
Maika8008
Tặng file quản lý vật tư - công nợ (nhập xuất kho hàng và công nợ khách hàng)
    • Thích
    • Yêu thích
    • Cảm ơn
4 5 6
Trả lời
112
Đọc
19K
Hongngoc710
Hongngoc710
V
  • Question
Tìm kiếm và copy giá trị từ bảng đến bảng khác
Trả lời
5
Đọc
74
BuiQuangThuan
B
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom