Bài toán lấy dữ liệu từ một sheet này sang một sheet khác:

Liên hệ QC
HieuCD đã viết:
Không có dữ liệu làm sao điền :mad:
Nhấp chuột vào đây để mở rộng...
Như ý ban đầu của em là lấy dữ liệu từ Sheet(Thau_Nhan Su) để điền sang sheet(List_Kinh Nghiem).
File Em đính kèm bài #21 đã có dữ liệu từ Sheet(Thau_Nhan Su).
Anh có hướng dẫn "cần lấy người nào thì copy tên và dán vào cột B sau đó chạy code "
Em đã dán tên vào cột B của sheet(List_Kinh Nghiem) sau đó chạy code thì báo "không có dữ liệu" và sau đó dán tên vào cột B của sheet còn lại cũng đều không được.
Anh có thể giúp đính kèm file có code luôn giúp em được không ạ?
 
Lần chỉnh sửa cuối:
Bùi Thúy Thúy đã viết:
Như ý ban đầu của em là lấy dữ liệu từ Sheet(Thau_Nhan Su) để điền sang sheet(List_Kinh Nghiem).
File Em đính kèm bài #21 đã có dữ liệu từ Sheet(Thau_Nhan Su).
Anh có hướng dẫn "cần lấy người nào thì copy tên và dán vào cột B sau đó chạy code "
Em đã dán tên vào cột B của sheet(List_Kinh Nghiem) sau đó chạy code thì báo "không có dữ liệu" và sau đó dán tên vào cột B của sheet còn lại cũng đều không được.
Anh có thể giúp đính kèm file có code luôn giúp em được không ạ?
Nhấp chuột vào đây để mở rộng...
Mình lại tưởng ngược lại o_O:(
Mã: 
Sub ListkinhNghiem()
  Dim sArr(), aDanhSach(), S, S2, Res(), ikey$, tmp$
  Dim eRow&, sRow&, i&, j&, iR&, jC&, k&

  With Sheets("List_Kinh Nghiem")
    eRow = .Range("D" & Rows.Count).End(xlUp).Row
    If eRow < 7 Then MsgBox ("Khong co du lieu"): Exit Sub
    aDanhSach = .Range("D7:D" & eRow).Value
  End With
  With Sheets("Thau_Nhan Su")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow < 15 Then MsgBox ("Khong co du lieu"): Exit Sub
    sArr = .Range("B15:I" & eRow).Value
  End With
  sRow = UBound(aDanhSach, 1)
  k = 1
  ReDim Res(1 To UBound(aDanhSach, 1), 1 To 3 * k)
  With CreateObject("scripting.dictionary")
    For i = 1 To sRow
      ikey = aDanhSach(i, 1)
      If Len(ikey) > 0 Then .Item(ikey) = i
    Next i
    sRow = UBound(sArr, 1)
    For i = 1 To sRow
      iR = .Item(sArr(i, 1))
      If iR > 0 Then
        S = Split(Chr(10) & sArr(i, 8), Chr(10))
        For j = 1 To UBound(S)
          tmp = Mid(S(j), 3, Len(S(j)))
          If InStr(1, tmp, "/") > 0 Then
            S2 = Split(tmp, "/")
            If j > k Then
              k = j
              ReDim Preserve Res(1 To UBound(aDanhSach, 1), 1 To 3 * k)
            End If
            jC = 3 * (j - 1) + 1
            Res(iR, jC) = S2(0)
            Res(iR, jC + 1) = S2(1)
            If UBound(S2) = 2 Then Res(iR, jC + 2) = S2(2)
          End If
        Next j
      End If
    Next i
  End With
  With Sheets("List_Kinh Nghiem")
    .Range("E7").Resize(UBound(Res), UBound(Res, 2)) = Res
  End With
End Sub
 

File đính kèm

  • TG4.xlsm
    62.6 KB · Đọc: 6
HieuCD đã viết:
Mình lại tưởng ngược lại o_O:(
Mã: 
Sub ListkinhNghiem()
  Dim sArr(), aDanhSach(), S, S2, Res(), ikey$, tmp$
  Dim eRow&, sRow&, i&, j&, iR&, jC&, k&

  With Sheets("List_Kinh Nghiem")
    eRow = .Range("D" & Rows.Count).End(xlUp).Row
    If eRow < 7 Then MsgBox ("Khong co du lieu"): Exit Sub
    aDanhSach = .Range("D7:D" & eRow).Value
  End With
  With Sheets("Thau_Nhan Su")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow < 15 Then MsgBox ("Khong co du lieu"): Exit Sub
    sArr = .Range("B15:I" & eRow).Value
  End With
  sRow = UBound(aDanhSach, 1)
  k = 1
  ReDim Res(1 To UBound(aDanhSach, 1), 1 To 3 * k)
  With CreateObject("scripting.dictionary")
    For i = 1 To sRow
      ikey = aDanhSach(i, 1)
      If Len(ikey) > 0 Then .Item(ikey) = i
    Next i
    sRow = UBound(sArr, 1)
    For i = 1 To sRow
      iR = .Item(sArr(i, 1))
      If iR > 0 Then
        S = Split(Chr(10) & sArr(i, 8), Chr(10))
        For j = 1 To UBound(S)
          tmp = Mid(S(j), 3, Len(S(j)))
          If InStr(1, tmp, "/") > 0 Then
            S2 = Split(tmp, "/")
            If j > k Then
              k = j
              ReDim Preserve Res(1 To UBound(aDanhSach, 1), 1 To 3 * k)
            End If
            jC = 3 * (j - 1) + 1
            Res(iR, jC) = S2(0)
            Res(iR, jC + 1) = S2(1)
            If UBound(S2) = 2 Then Res(iR, jC + 2) = S2(2)
          End If
        Next j
      End If
    Next i
  End With
  With Sheets("List_Kinh Nghiem")
    .Range("E7").Resize(UBound(Res), UBound(Res, 2)) = Res
  End With
End Sub
Nhấp chuột vào đây để mở rộng...
Dạ! em cảm ơn anh, anh ơi cho em hỏi thêm chút ạ!
Giả sử trong sheet (Thau_Nhan Su) Em đổi tên Sheet thành Sheet(DM_HD)
Dữ liệu cột I trong Sheet(DM_HD) (cột lấy dữ liệu để điền) em chuyển sang cột AA và có sửa lại code như sau thì thấy tác động anh ạ!
Anh xem giúp em mới ạ!
Mã: 
Sub ListkinhNghiem()
  Dim sArr(), aDanhSach(), S, S2, Res(), ikey$, tmp$
  Dim eRow&, sRow&, i&, j&, iR&, jC&, k&

  With Sheets("List_Kinh Nghiem")
    eRow = .Range("D" & Rows.Count).End(xlUp).Row
    If eRow < 7 Then MsgBox ("Khong co du lieu"): Exit Sub
    aDanhSach = .Range("D7:D" & eRow).Value
  End With
  With Sheets("DM_HD")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow < 15 Then MsgBox ("Khong co du lieu"): Exit Sub
    sArr = .Range("D15:AA" & eRow).Value
  End With
  sRow = UBound(aDanhSach, 1)
  k = 1
  ReDim Res(1 To UBound(aDanhSach, 1), 1 To 3 * k)
  With CreateObject("scripting.dictionary")
    For i = 1 To sRow
      ikey = aDanhSach(i, 1)
      If Len(ikey) > 0 Then .Item(ikey) = i
    Next i
    sRow = UBound(sArr, 1)
    For i = 1 To sRow
      iR = .Item(sArr(i, 1))
      If iR > 0 Then
        S = Split(Chr(10) & sArr(i, 8), Chr(10))
        For j = 1 To UBound(S)
          tmp = Mid(S(j), 3, Len(S(j)))
          If InStr(1, tmp, "/") > 0 Then
            S2 = Split(tmp, "/")
            If j > k Then
              k = j
              ReDim Preserve Res(1 To UBound(aDanhSach, 1), 1 To 3 * k)
            End If
            jC = 3 * (j - 1) + 1
            Res(iR, jC) = S2(0)
            Res(iR, jC + 1) = S2(1)
            If UBound(S2) = 2 Then Res(iR, jC + 2) = S2(2)
          End If
        Next j
      End If
    Next i
  End With
  With Sheets("List_Kinh Nghiem")
    .Range("E7").Resize(UBound(Res), UBound(Res, 2)) = Res
  End With
End Sub
 

File đính kèm

  • thu.xlsm
    61.1 KB · Đọc: 6
Lần chỉnh sửa cuối:
Bùi Thúy Thúy đã viết:
Dạ! em cảm ơn anh, anh ơi cho em hỏi thêm chút ạ!
Giả sử trong sheet (Thau_Nhan Su) Em đổi tên Sheet thành Sheet(DM_HD)
Dữ liệu cột I trong Sheet(DM_HD) (cột lấy dữ liệu để điền) em chuyển sang cột AA và có sửa lại code như sau thì thấy tác động anh ạ!
Anh xem giúp em mới ạ!
Mã: 
Sub ListkinhNghiem()
  Dim sArr(), aDanhSach(), S, S2, Res(), ikey$, tmp$
  Dim eRow&, sRow&, i&, j&, iR&, jC&, k&

  With Sheets("List_Kinh Nghiem")
    eRow = .Range("D" & Rows.Count).End(xlUp).Row
    If eRow < 7 Then MsgBox ("Khong co du lieu"): Exit Sub
    aDanhSach = .Range("D7:D" & eRow).Value
  End With
  With Sheets("DM_HD")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow < 15 Then MsgBox ("Khong co du lieu"): Exit Sub
    sArr = .Range("D15:AA" & eRow).Value
  End With
  sRow = UBound(aDanhSach, 1)
  k = 1
  ReDim Res(1 To UBound(aDanhSach, 1), 1 To 3 * k)
  With CreateObject("scripting.dictionary")
    For i = 1 To sRow
      ikey = aDanhSach(i, 1)
      If Len(ikey) > 0 Then .Item(ikey) = i
    Next i
    sRow = UBound(sArr, 1)
    For i = 1 To sRow
      iR = .Item(sArr(i, 1))
      If iR > 0 Then
        S = Split(Chr(10) & sArr(i, 8), Chr(10))
        For j = 1 To UBound(S)
          tmp = Mid(S(j), 3, Len(S(j)))
          If InStr(1, tmp, "/") > 0 Then
            S2 = Split(tmp, "/")
            If j > k Then
              k = j
              ReDim Preserve Res(1 To UBound(aDanhSach, 1), 1 To 3 * k)
            End If
            jC = 3 * (j - 1) + 1
            Res(iR, jC) = S2(0)
            Res(iR, jC + 1) = S2(1)
            If UBound(S2) = 2 Then Res(iR, jC + 2) = S2(2)
          End If
        Next j
      End If
    Next i
  End With
  With Sheets("List_Kinh Nghiem")
    .Range("E7").Resize(UBound(Res), UBound(Res, 2)) = Res
  End With
End Sub
Nhấp chuột vào đây để mở rộng...
Chỉnh code cho bạn dể thay đổi thứ tự cột
Mã: 
Sub ListkinhNghiem()
  Dim aHoTen(), aLyLich(), aDanhSach(), S, S2, Res(), ikey$, tmp$
  Dim eRow&, sRow&, i&, j&, iR&, jC&, k&

  With Sheets("List_Kinh Nghiem")
    eRow = .Range("D" & Rows.Count).End(xlUp).Row
    If eRow < 7 Then MsgBox ("Khong co du lieu"): Exit Sub
    aDanhSach = .Range("D7:D" & eRow).Value
  End With
  With Sheets("DM_HD")
    eRow = .Range("D" & Rows.Count).End(xlUp).Row 'Cot Ten nguoi lao dong
    If eRow < 15 Then MsgBox ("Khong co du lieu"): Exit Sub
    aHoTen = .Range("D15:D" & eRow).Value
    aLyLich = .Range("AA15:AA" & eRow).Value
  End With
  sRow = UBound(aDanhSach, 1)
  k = 1
  ReDim Res(1 To UBound(aDanhSach, 1), 1 To 3 * k)
  With CreateObject("scripting.dictionary")
    For i = 1 To sRow
      ikey = aDanhSach(i, 1)
      If Len(ikey) > 0 Then .Item(ikey) = i
    Next i
    sRow = UBound(aHoTen, 1)
    For i = 1 To sRow
      iR = .Item(aHoTen(i, 1))
      If iR > 0 Then
        S = Split(Chr(10) & aLyLich(i, 1), Chr(10))
        For j = 1 To UBound(S)
          tmp = Mid(S(j), 3, Len(S(j)))
          If InStr(1, tmp, "/") > 0 Then
            S2 = Split(tmp, "/")
            If j > k Then
              k = j
              ReDim Preserve Res(1 To UBound(aDanhSach, 1), 1 To 3 * k)
            End If
            jC = 3 * (j - 1) + 1
            Res(iR, jC) = S2(0)
            Res(iR, jC + 1) = S2(1)
            If UBound(S2) = 2 Then Res(iR, jC + 2) = S2(2)
          End If
        Next j
      End If
    Next i
  End With
  With Sheets("List_Kinh Nghiem")
    .Range("E7").Resize(UBound(Res), UBound(Res, 2)) = Res
  End With
End Sub
 
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

S
Sao excel lại biến dữ liệu thành dữ liệu nhiều các con số?
Trả lời
7
Đọc
51
ongke0711
ongke0711
LuuAnh980
  • Question
Code lấy dữ liệu từ 3 file con.
2 3 4
Trả lời
60
Đọc
872
CHAOQUAY
C
C
Hàm Textjoin nối chuỗi có định dạng ngày tháng
Trả lời
10
Đọc
405
polyvietnam
polyvietnam
T
Nhờ giúp tính tổng ô đã Merge
Trả lời
0
Đọc
12
thuytrangbp28
T
emlat3
Đặt màu xen kẽ các dòng theo ký tự
Trả lời
5
Đọc
121
VetMini
V
Xem thêm…

Facebook

Giaiphapexcel.com

Group

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

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