Viết code lấy dữ liệu

Liên hệ QC
C

chisinhvnn

Thành viên tiêu biểu
Tham gia
7/3/08
Bài viết
479
Được thích
103
Nhờ GPE gúp mình lấy số liệu từ sheet"dulieu" sang sheet"thamdinh" với.
Cách lấy số liệu: từ sheet"dulieu" qua sheets"thamdinh"
+ Đối với giá trị họ tên thì thê hiện Họ tên, Năm sinh, CMND (Nguyễn Văn A, Sinh năm 1987, CMND số 191514598)
+ Đối với giá trị tài sản: nếu cột kích thước có giá trị thi nối cột Tài sản và kích thước và "m" (Nhà cấp 4: Nhà móng BT; cột BTCT; tường chịu lực xây gạch; mái ngói, tôn; nền xi măng, không có khu phụ trong nhà , kích thước: 7.5 x 3.5 m).
Nhờ GPE giúp đỡ.
 

File đính kèm

  • lay so lieu.xlsx
    363.3 KB · Đọc: 43
Sắp xếp theo thời gian sắp xếp theo bầu chọn
chisinhvnn đã viết:
Nhờ GPE gúp mình lấy số liệu từ sheet"dulieu" sang sheet"thamdinh" với.
Cách lấy số liệu: từ sheet"dulieu" qua sheets"thamdinh"
+ Đối với giá trị họ tên thì thê hiện Họ tên, Năm sinh, CMND (Nguyễn Văn A, Sinh năm 1987, CMND số 191514598)
+ Đối với giá trị tài sản: nếu cột kích thước có giá trị thi nối cột Tài sản và kích thước và "m" (Nhà cấp 4: Nhà móng BT; cột BTCT; tường chịu lực xây gạch; mái ngói, tôn; nền xi măng, không có khu phụ trong nhà , kích thước: 7.5 x 3.5 m).
Nhờ GPE giúp đỡ.
Nhấp chuột vào đây để mở rộng...
Anh thử chạy Sub này thử xem sao
Mã: 
Sub Layulieu()
    Dim sArr(), tArr(), dArr(), Arr()
    Dim Dic As Object, I As Long, J As Long, K As Long, R As Long, KT As String
Set Dic = CreateObject("Scripting.Dictionary")
KT = ", K" & ChrW$(237) & "ch th" & ChrW$(432) & ChrW$(7899) & "c: "
With Sheets("Dulieu")
    Arr = .Range("B3:G3").Value
    tArr = .Range("B4", .Range("B65535").End(3)).Resize(, 6).Value
End With
For I = 1 To UBound(tArr)
    Dic.Item(tArr(I, 1)) = I
Next I
With Sheets("Dulieu")
    sArr = .Range("L4", .Range("L65535").End(3)).Resize(, 9).Value
End With
ReDim dArr(1 To UBound(sArr) * 2, 1 To 9)
For I = 1 To UBound(sArr)
    R = Dic.Item(sArr(I, 1))
    K = K + 1
    dArr(K, 1) = I
    dArr(K, 2) = tArr(R, 2)
    For J = 3 To 6
        If tArr(R, J) <> Empty Then dArr(K, 2) = dArr(K, 2) & "; " & Arr(1, J) & ": " & tArr(R, J)
    Next J
    K = K + 1
    If sArr(I, 4) <> Empty Then
        dArr(K, 2) = sArr(I, 3) & KT & sArr(I, 4)
    Else
        dArr(K, 2) = sArr(I, 3)
    End If
    dArr(K, 3) = sArr(I, 5): dArr(K, 4) = sArr(I, 6): dArr(K, 5) = sArr(I, 7)
    dArr(K, 6) = sArr(I, 8): dArr(K, 7) = sArr(I, 9)
Next I
With Sheets("ThamDinh")
    .Range("A6:H1000").ClearContents
    .Range("A6").Resize(K, 9) = dArr
End With
Set Dic = Nothing
End Sub
Mà Cột thành tiền hình như bị sai đó anh à./
 
Upvote 0
PacificPR đã viết:
Anh thử chạy Sub này thử xem sao
Mã: 
Sub Layulieu()
    Dim sArr(), tArr(), dArr(), Arr()
    Dim Dic As Object, I As Long, J As Long, K As Long, R As Long, KT As String
Set Dic = CreateObject("Scripting.Dictionary")
KT = ", K" & ChrW$(237) & "ch th" & ChrW$(432) & ChrW$(7899) & "c: "
With Sheets("Dulieu")
    Arr = .Range("B3:G3").Value
    tArr = .Range("B4", .Range("B65535").End(3)).Resize(, 6).Value
End With
For I = 1 To UBound(tArr)
    Dic.Item(tArr(I, 1)) = I
Next I
With Sheets("Dulieu")
    sArr = .Range("L4", .Range("L65535").End(3)).Resize(, 9).Value
End With
ReDim dArr(1 To UBound(sArr) * 2, 1 To 9)
For I = 1 To UBound(sArr)
    R = Dic.Item(sArr(I, 1))
    K = K + 1
    dArr(K, 1) = I
    dArr(K, 2) = tArr(R, 2)
    For J = 3 To 6
        If tArr(R, J) <> Empty Then dArr(K, 2) = dArr(K, 2) & "; " & Arr(1, J) & ": " & tArr(R, J)
    Next J
    K = K + 1
    If sArr(I, 4) <> Empty Then
        dArr(K, 2) = sArr(I, 3) & KT & sArr(I, 4)
    Else
        dArr(K, 2) = sArr(I, 3)
    End If
    dArr(K, 3) = sArr(I, 5): dArr(K, 4) = sArr(I, 6): dArr(K, 5) = sArr(I, 7)
    dArr(K, 6) = sArr(I, 8): dArr(K, 7) = sArr(I, 9)
Next I
With Sheets("ThamDinh")
    .Range("A6:H1000").ClearContents
    .Range("A6").Resize(K, 9) = dArr
End With
Set Dic = Nothing
End Sub
Mà Cột thành tiền hình như bị sai đó anh à./
Nhấp chuột vào đây để mở rộng...
Thấy bạn hay dùng Dic, có thể hướng dẫn giúp mình quy trình vận hành nó được không, mình có đọc trên GPE nhưng không thông lắm
 
Upvote 0
chisinhvnn đã viết:
Thấy bạn hay dùng Dic, có thể hướng dẫn giúp mình quy trình vận hành nó được không, mình có đọc trên GPE nhưng không thông lắm
Nhấp chuột vào đây để mở rộng...
Em đi học mót trên diễn đàn lên đâu có căn cơ gì đâu anh. Hướng dẫn anh nếu sai thì chết em :D. Không dùng Dic thì mình dùng VLOOKUP cũng được ạ
 
Upvote 0
Một mã đối tượng thì mình chỉ cho xuất hiện tên 1 lần, còn phần tài sản thì thi theo mã đối tượng bên dưới dòng hoten. File kèm theo cảu anh đấy ví dụ ở sheet"thamdinh: sở số stt 3 em sẽ thấy afh.
 
Upvote 0
Anh dùng thử cái này xem sao
Mã: 
Sub Layulieu()
    Dim sArr(), dArr(), Arr()
    Dim Dic As Object, I As Long, J As Long, K As Long, R As Long, KT As String
    Dim Rng As Range, v As Variant, Stt As Long, Sodem As Long, Tam As String
Set Dic = CreateObject("Scripting.Dictionary")
KT = ", K" & ChrW$(237) & "ch th" & ChrW$(432) & ChrW$(7899) & "c: "
With Sheets("Dulieu")
    Set Rng = .Range("B4", .Range("B65535").End(3)).Resize(, 6)
    Arr = .Range("B3:G3").Value
    sArr = .Range("L4", .Range("L65535").End(3)).Resize(, 9).Value
End With
For I = 1 To UBound(sArr)
    Dic(sArr(I, 1)) = 1
Next I
ReDim dArr(1 To UBound(sArr) * 2, 1 To 9)
For Each v In Dic.keys()
    For I = 1 To UBound(sArr)
        If sArr(I, 1) = v Then
            Sodem = Sodem + 1
            If Sodem = 1 Then
                K = K + 1: Stt = Stt + 1
                dArr(K, 1) = Stt
                dArr(K, 2) = Application.VLookup(v, Rng, 2, False)
                For J = 3 To 4
                    Tam = Application.VLookup(v, Rng, J, False)
                    If Tam <> Empty Then dArr(K, 2) = dArr(K, 2) & "; " & Arr(1, J) & ": " & Tam
                Next J
            End If
            K = K + 1
            If sArr(I, 4) <> Empty Then
                dArr(K, 2) = sArr(I, 3) & KT & sArr(I, 4) & " m"
            Else
                dArr(K, 2) = sArr(I, 3)
            End If
            dArr(K, 3) = sArr(I, 5): dArr(K, 4) = sArr(I, 6): dArr(K, 5) = sArr(I, 7)
            dArr(K, 6) = sArr(I, 8): dArr(K, 7) = sArr(I, 9)
        End If
    Next I
    Sodem = 0
Next
With Sheets("ThamDinh")
    .Range("A6:H1000").ClearContents
    .Range("A6").Resize(K, 9) = dArr
End With
Set Dic = Nothing
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
PacificPR đã viết:
Anh dùng thử cái này xem sao
Mã: 
Sub Layulieu()
    Dim sArr(), dArr(), Arr()
    Dim Dic As Object, I As Long, J As Long, K As Long, R As Long, KT As String
    Dim Rng As Range, v As Variant, Stt As Long, Sodem As Long, Tam As String
Set Dic = CreateObject("Scripting.Dictionary")
KT = ", K" & ChrW$(237) & "ch th" & ChrW$(432) & ChrW$(7899) & "c: "
With Sheets("Dulieu")
    Set Rng = .Range("B4", .Range("B65535").End(3)).Resize(, 6)
    Arr = .Range("B3:G3").Value
    sArr = .Range("L4", .Range("L65535").End(3)).Resize(, 9).Value
End With
For I = 1 To UBound(sArr)
    Dic(sArr(I, 1)) = 1
Next I
ReDim dArr(1 To UBound(sArr) * 2, 1 To 9)
For Each v In Dic.keys()
    For I = 1 To UBound(sArr)
        If sArr(I, 1) = v Then
            Sodem = Sodem + 1
            If Sodem = 1 Then
                K = K + 1: Stt = Stt + 1
                dArr(K, 1) = Stt
                dArr(K, 2) = Application.VLookup(v, Rng, 2, False)
                For J = 3 To 4
                    Tam = Application.VLookup(v, Rng, J, False)
                    If Tam <> Empty Then dArr(K, 2) = dArr(K, 2) & "; " & Arr(1, J) & ": " & Tam
                Next J
            End If
            K = K + 1
            If sArr(I, 4) <> Empty Then
                dArr(K, 2) = sArr(I, 3) & KT & sArr(I, 4) & " m"
            Else
                dArr(K, 2) = sArr(I, 3)
            End If
            dArr(K, 3) = sArr(I, 5): dArr(K, 4) = sArr(I, 6): dArr(K, 5) = sArr(I, 7)
            dArr(K, 6) = sArr(I, 8): dArr(K, 7) = sArr(I, 9)
        End If
    Next I
    Sodem = 0
Next
With Sheets("ThamDinh")
    .Range("A6:H1000").ClearContents
    .Range("A6").Resize(K, 9) = dArr
End With
Set Dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
Em ghi chú thích từng phân đoạn cho anh với
 
Upvote 0
PacificPR đã viết:
Anh dùng thử cái này xem sao
Mã: 
Sub Layulieu()
Dim sArr(), dArr(), Arr()
   Dim Dic As Object, I As Long, J As Long, K As Long, R As Long, KT As String
   Dim Rng As Range, v As Variant, Stt As Long, Sodem As Long, Tam As String
Set Dic = CreateObject("Scripting.Dictionary")
KT = ", K" & ChrW$(237) & "ch th" & ChrW$(432) & ChrW$(7899) & "c: "
With Sheets("Dulieu")
   Set Rng = .Range("B4", .Range("B65535").End(3)).Resize(, 6)
   Arr = .Range("B3:G3").Value
   sArr = .Range("L4", .Range("L65535").End(3)).Resize(, 9).Value
End With
For I = 1 To UBound(sArr)
   Dic(sArr(I, 1)) = 1
Next I
ReDim dArr(1 To UBound(sArr) * 2, 1 To 9)
For Each v In Dic.keys()
   For I = 1 To UBound(sArr)
       If sArr(I, 1) = v Then
           Sodem = Sodem + 1
           If Sodem = 1 Then
               K = K + 1: Stt = Stt + 1
               dArr(K, 1) = Stt
               dArr(K, 2) = Application.VLookup(v, Rng, 2, False)
               For J = 3 To 4
                   Tam = Application.VLookup(v, Rng, J, False)
                   If Tam <> Empty Then dArr(K, 2) = dArr(K, 2) & "; " & Arr(1, J) & ": " & Tam
               Next J
           End If
           K = K + 1
           If sArr(I, 4) <> Empty Then
               dArr(K, 2) = sArr(I, 3) & KT & sArr(I, 4) & " m"
           Else
               dArr(K, 2) = sArr(I, 3)
           End If
           dArr(K, 3) = sArr(I, 5): dArr(K, 4) = sArr(I, 6): dArr(K, 5) = sArr(I, 7)
           dArr(K, 6) = sArr(I, 8): dArr(K, 7) = sArr(I, 9)
       End If
   Next I
   Sodem = 0
Next
With Sheets("ThamDinh")
   .Range("A6:H1000").ClearContents
   .Range("A6").Resize(K, 9) = dArr
End With
Set Dic = Nothing

End Sub
Nhấp chuột vào đây để mở rộng...
Giải thích giúp mình đoạn code này với: Dic(sArr(I, 1)) = 1, Dic =1 có ý nghĩa gì vậy, với ReDim dArr(1 To UBound(sArr) * 2, 1 To 9), tại sao mình redim UBound(sArr) * 2, mình chưa hiểu lắm 2 đoạn code trên. GPE giúp mình tìm hiểu với.
 
Upvote 0
chisinhvnn đã viết:
Giải thích giúp mình đoạn code này với: Dic(sArr(I, 1)) = 1, Dic =1 có ý nghĩa gì vậy, với ReDim dArr(1 To UBound(sArr) * 2, 1 To 9), tại sao mình redim UBound(sArr) * 2, mình chưa hiểu lắm 2 đoạn code trên. GPE giúp mình tìm hiểu với.
Nhấp chuột vào đây để mở rộng...
(1) Dic(sArr(I, 1)) = 1 thì anh lại phải sang đây đọc rồi :D ( Nó nằm trong mục Thuộc tính Item nha anh)
http://www.giaiphapexcel.com/diendan/threads/tổng-quan-về-scripting-dictionary.60643/
(2) ReDim dArr(1 To UBound(sArr) * 2, 1 To 9) là khai báo mảng dArr
Có nghĩa là mảng dArr có kích thưc
- Số dòng từ 1 đến dòng cuối mảng sArr * 2 (Số hàng gấp đôi mảng sArr)
- Số cột từ 1 đến 9 ( Có 9 cột)
Trong đó Ubound(sArr) hay Ubound(sArr,1) là dòng cuối của mảng sArr: Ubound(sArr,2) là cột cuối của mảng sArr
 
Upvote 0
PacificPR đã viết:
(1) Dic(sArr(I, 1)) = 1 thì anh lại phải sang đây đọc rồi :D ( Nó nằm trong mục Thuộc tính Item nha anh)
http://www.giaiphapexcel.com/diendan/threads/tổng-quan-về-scripting-dictionary.60643/
(2) ReDim dArr(1 To UBound(sArr) * 2, 1 To 9) là khai báo mảng dArr
Có nghĩa là mảng dArr có kích thưc
- Số dòng từ 1 đến dòng cuối mảng sArr * 2 (Số hàng gấp đôi mảng sArr)
- Số cột từ 1 đến 9 ( Có 9 cột)
Trong đó Ubound(sArr) hay Ubound(sArr,1) là dòng cuối của mảng sArr: Ubound(sArr,2) là cột cuối của mảng sArr
Nhấp chuột vào đây để mở rộng...
Mình muốn hỏi vì sao lại *2 àh
 
Upvote 0
PacificPR đã viết:
Anh dùng thử cái này xem sao
Mã: 
Sub Layulieu()
    Dim sArr(), dArr(), Arr()
    Dim Dic As Object, I As Long, J As Long, K As Long, R As Long, KT As String
    Dim Rng As Range, v As Variant, Stt As Long, Sodem As Long, Tam As String
Set Dic = CreateObject("Scripting.Dictionary")
KT = ", K" & ChrW$(237) & "ch th" & ChrW$(432) & ChrW$(7899) & "c: "
With Sheets("Dulieu")
    Set Rng = .Range("B4", .Range("B65535").End(3)).Resize(, 6)
    Arr = .Range("B3:G3").Value
    sArr = .Range("L4", .Range("L65535").End(3)).Resize(, 9).Value
End With
For I = 1 To UBound(sArr)
    Dic(sArr(I, 1)) = 1
Next I

ReDim dArr(1 To UBound(sArr) * 2, 1 To 9)
For Each v In Dic.keys()
    For I = 1 To UBound(sArr)
        If sArr(I, 1) = v Then
            Sodem = Sodem + 1
            If Sodem = 1 Then
                K = K + 1: Stt = Stt + 1
                dArr(K, 1) = Stt
                dArr(K, 2) = Application.VLookup(v, Rng, 2, False)
                For J = 3 To 4
                    Tam = Application.VLookup(v, Rng, J, False)
                    If Tam <> Empty Then dArr(K, 2) = dArr(K, 2) & "; " & Arr(1, J) & ": " & Tam
                Next J
            End If
            K = K + 1
            If sArr(I, 4) <> Empty Then
                dArr(K, 2) = sArr(I, 3) & KT & sArr(I, 4) & " m"
            Else
                dArr(K, 2) = sArr(I, 3)
            End If
            dArr(K, 3) = sArr(I, 5): dArr(K, 4) = sArr(I, 6): dArr(K, 5) = sArr(I, 7)
            dArr(K, 6) = sArr(I, 8): dArr(K, 7) = sArr(I, 9)
        End If
    Next I
    Sodem = 0
Next
With Sheets("ThamDinh")
    .Range("A6:H1000").ClearContents
    .Range("A6").Resize(K, 9) = dArr
End With
Set Dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
Với code này, mình có chỉnh sửa lại để lọc dữ liệu nhưng báo lỗi bạn xem giúp mình tý.
Mình thêm các dòng code sau:

If Sheet1.Range("w2").Value = "" Then
(phần code của bạn ở trên)
else
ReDim darr1(1 To UBound(sArr), 1 To 11)
For n = 1 To UBound(sArr)
If sArr(n, 12) = Sheet1.[w2] Then
K = K + 1

darr1(K, 1) = sArr(n, 1)
For J = 2 To 11
darr1(K, J) = sArr(n, J)
Next J
End If
Next n
(Mình tạo ra mãng dữ liệu số số cột khong thay đổi)
If Sheet1.[b4] = "" Then Exit Sub
For i = 1 To UBound(darr1)
Dic(darr1(i, 1)) = 1
Next i
ReDim dArr(1 To UBound(darr1) * 2, 1 To 9)
For Each v In Dic.keys()
For i = 1 To UBound(darr1)
If darr1(i, 1) = v Then
Sodem = Sodem + 1
If Sodem = 1 Then
K = K + 1: Stt = Stt + 1
dArr(K, 1) = Stt
dArr(K, 2) = Application.VLookup(v, Rng, 2, False)
For J = 3 To 4
Tam = Application.VLookup(v, Rng, J, False)
If Tam <> Empty Then dArr(K, 2) = dArr(K, 2) & "; " & arr(1, J) & ": " & Tam
Next J
End If
K = K + 1
If darr1(i, 4) <> Empty Then
dArr(K, 2) = darr1(i, 3) & KT & darr1(i, 4) & " m"
Else
dArr(K, 2) = darr1(i, 3)
End If
dArr(K, 3) = darr1(i, 5): dArr(K, 4) = darr1(i, 6): dArr(K, 5) = darr1(i, 7)
dArr(K, 6) = darr1(i, 8): dArr(K, 7) = darr1(i, 9): dArr(K, 8) = darr1(i, 10)
dArr(K, 9) = darr1(i, 11)
End If
Next i
Sodem = 0
Next
With Sheets("ThamDinh")
.Range("A6:N10000").ClearContents
.Range("A6:N10000").ClearFormats
.Range("A6").Resize(K, 9) = dArr
End With

Set Dic = Nothing
Application.ScreenUpdating = True
Sheet3.Activate
Call tinhtien2
Call dinhdang2


End If
 
Upvote 0
chisinhvnn đã viết:
Với code này, mình có chỉnh sửa lại để lọc dữ liệu nhưng báo lỗi bạn xem giúp mình tý.
Nhấp chuột vào đây để mở rộng...
Tìm tới chỗ chuyên để ghi code ấy, cho khúc trên vào đó.
Người ta làm giúp mình còn cho vào đó để khi mình nhận hàng còn biết lấy về.
Vậy mình đi hỏi cũng cố mà làm được như thế. Nếu không làm được như thế thì hết cách!
 
Upvote 0
befaint đã viết:
Tìm tới chỗ chuyên để ghi code ấy, cho khúc trên vào đó.
Người ta làm giúp mình còn cho vào đó để khi mình nhận hàng còn biết lấy về.
Vậy mình đi hỏi cũng cố mà làm được như thế. Nếu không làm được như thế thì hết cách!
Nhấp chuột vào đây để mở rộng...
Nói thật là mình chưa biết cách đưa code vào trong ô code như thế nào. Nhờ bạn chỉ giúp mình
 
Lần chỉnh sửa cuối:
Upvote 0
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

maytinhvp01
  • Question
Chuyên đề giải đáp những thắc mắc về code VBA
    • Thích
151 152 153
Trả lời
3K
Đọc
275K
HieuCD
H
hongquan93vn
Tìm công thức có thể đánh STT của giá trị mỗi lần xuất hiện
2
Trả lời
22
Đọc
200
VetMini
V
Justine Miller
em cần sự trợ giúp
Trả lời
3
Đọc
44
CHAOQUAY
C
8
  • Question
Xin giúp: Nhóm (group data) các dòng trong bảng tính
Trả lời
11
Đọc
408
forcebk
F
hung2412
  • Question
Có Code VBA nào để tự động điều chỉnh tỷ lệ hiển thị màn hình theo thông số Recommended (Theo từng Laptop, PC)?
Trả lời
5
Đọc
130
befaint
befaint
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