Nhờ anh chị giúp đỡ code lấy giữ liệu từ 1 cột phụ (1 người xem)
- Thread starter vova2209
- Ngày gửi
Người dùng đang xem chủ đề này
♫ђöล♥ßล†♥†µ♫
Thành viên tiêu biểu
- Tham gia
- 10/3/18
- Bài viết
- 684
- Được thích
- 1,443
- Giới tính
- Nữ
- Nghề nghiệp
- Worksheet Function trong VBA , Thư viện mã lập trình, Scripting.Dictionary, Sổ tay VBA, Các hàm dò tìm và tham chiếu
Mã:
Sub Nghich_ty_nha()
Dim i As Long, Er As Long, Tem As String
Er = Range("C" & Rows.Count).End(xlUp).Row
For i = Er To 3 Step -1
If Tem = "" Then
Tem = "=" & Range("F" & i).Address
Else
Tem = Tem & Range("J1") & Range("F" & i).Address
End If
If Range("D" & i) = Empty Then
Range("G" & i) = Tem: Tem = ""
End If
Next i
End Sub
Upvote
0
♫ђöล♥ßล†♥†µ♫
Thành viên tiêu biểu
- Tham gia
- 10/3/18
- Bài viết
- 684
- Được thích
- 1,443
- Giới tính
- Nữ
- Nghề nghiệp
- Worksheet Function trong VBA , Thư viện mã lập trình, Scripting.Dictionary, Sổ tay VBA, Các hàm dò tìm và tham chiếu
Vậy bạn thử cái này xem
Mã:
Sub Nghich_ty_thoi()
Dim Dic As Object, Keys As String
Dim sArr(), dArr(), I As Long
Set Dic = CreateObject("Scripting.Dictionary")
sArr = Range("D3", Range("F" & Rows.Count).End(3)).Value
ReDim dArr(1 To UBound(sArr, 1), 1 To 1)
For I = 1 To UBound(sArr, 1)
If sArr(I, 1) = Empty Then Keys = "dong" & I
If Not Dic.Exists(Keys) Then
Dic.Add Keys, I
dArr(I, 1) = sArr(I, 3)
Else
dArr(Dic.Item(Keys), 1) = dArr(Dic.Item(Keys), 1) & "; " & sArr(I, 3)
End If
Next I
Range("H3").Resize(I - 1) = dArr
Set Dic = Nothing
End Sub
Upvote
0
Code trước quá đẹp, sao lại bỏ
Mã:
Sub Nghich_ty_2()
Dim i As Long, Er As Long, Tem As String
Er = Range("C" & Rows.Count).End(xlUp).Row
For i = Er To 3 Step -1
If Tem = "" Then
Tem = Range("F" & i).Value
Else
Tem = Range("F" & i).Value & "; " & Tem
End If
If Range("D" & i) = Empty Then Range("G" & i) = Tem: Tem = ""
Next i
End Sub
Upvote
0
♫ђöล♥ßล†♥†µ♫
Thành viên tiêu biểu
- Tham gia
- 10/3/18
- Bài viết
- 684
- Được thích
- 1,443
- Giới tính
- Nữ
- Nghề nghiệp
- Worksheet Function trong VBA , Thư viện mã lập trình, Scripting.Dictionary, Sổ tay VBA, Các hàm dò tìm và tham chiếu
Nhà họ nói em nó bị ngược Anh ạ. Em không biết đưa cái & "; " & vào trong VBA như thế nào. Anh giúp em vớiCode trước quá đẹp, sao lại bỏMã:Sub Nghich_ty_2() Dim i As Long, Er As Long, Tem As String Er = Range("C" & Rows.Count).End(xlUp).Row For i = Er To 3 Step -1 If Tem = "" Then Tem = Range("F" & i).Value Else Tem = Range("F" & i).Value & "; " & Tem End If If Range("D" & i) = Empty Then Range("G" & i) = Tem: Tem = "" Next i End Sub
Upvote
0
Ý nói kết quả bị ngược, còn code chạy ngược là quá ngon rồi
Upvote
0
Tiếng Việt, "Nghich" nghĩa là gì? Bị ngược là phải lý rồi.
Private Function NghichLai(byVal s as string, byVal delim as string) as string
' đảo ngược các chuỗi con trong một chuỗi
Dim s2 as variant, stmp as string, i1 as integer, i2 as integer
s2 = Split(s, delim)
i1 = lbound(s2)
i2 = ubound(s2)
if i1 = i2 Then ' chỉ có 1 chuỗi con
NghichLai = s
Else ' nhiều chuõi con
Do While i2 > i1
stmp = s2(i1)
s2(i1) = s2(i2)
s2(i2) = stmp
i1 = i1 + 1
i2 = i2 - 1
Loop
NghichLai = Join(s2, delim)
End If
End Function
...
If Range("D" & i) = Empty Then
Range("G" & i) = NghichLai(Tem, ";")
Tem = ""
End If
...
Nếu muốn nghịch nữa thì như vầy:
Range("G" & i) = NghichLai(NghichLai(Tem, ";"), ";")
Private Function NghichLai(byVal s as string, byVal delim as string) as string
' đảo ngược các chuỗi con trong một chuỗi
Dim s2 as variant, stmp as string, i1 as integer, i2 as integer
s2 = Split(s, delim)
i1 = lbound(s2)
i2 = ubound(s2)
if i1 = i2 Then ' chỉ có 1 chuỗi con
NghichLai = s
Else ' nhiều chuõi con
Do While i2 > i1
stmp = s2(i1)
s2(i1) = s2(i2)
s2(i2) = stmp
i1 = i1 + 1
i2 = i2 - 1
Loop
NghichLai = Join(s2, delim)
End If
End Function
...
If Range("D" & i) = Empty Then
Range("G" & i) = NghichLai(Tem, ";")
Tem = ""
End If
...
Nếu muốn nghịch nữa thì như vầy:
Range("G" & i) = NghichLai(NghichLai(Tem, ";"), ";")
Lần chỉnh sửa cuối:
Upvote
0
vova2209
Thành viên tích cực
- Tham gia
- 5/4/17
- Bài viết
- 835
- Được thích
- 112
- Giới tính
- Nam
- Nghề nghiệp
- Đường bộ
Cái này chuẩn rồi chị ạ: em hỏi thêm tý nữa ạ
+ Muốn cho code chạy từ dòng thứ 10 trở đi làm như nào ạ
+ nếu muốn hiện lại hàm thì sửa chỗ nào nhỉ chị
+ Chị Hướng dẫn ghi chú code cho em hiểu với
Mảng array chạy nhanh hơn vòng for nhiều nhỉ chị. Code chạy nhanh quá chóng hết cả mặt. Em cảm ơn nhiều à
Lần chỉnh sửa cuối:
Upvote
0
♫ђöล♥ßล†♥†µ♫
Thành viên tiêu biểu
- Tham gia
- 10/3/18
- Bài viết
- 684
- Được thích
- 1,443
- Giới tính
- Nữ
- Nghề nghiệp
- Worksheet Function trong VBA , Thư viện mã lập trình, Scripting.Dictionary, Sổ tay VBA, Các hàm dò tìm và tham chiếu
Sửa lại như vầy
Mã:
Sub Nghich_ty_thoi()
Dim Dic As Object, Keys As String
Dim sArr(), dArr(), I As Long
Set Dic = CreateObject("Scripting.Dictionary")
sArr = Range("D3", Range("F" & Rows.Count).End(3)).Value
ReDim dArr(1 To UBound(sArr, 1), 1 To 1)
For I = 1 To UBound(sArr, 1)
If sArr(I, 1) = Empty Then Keys = "dong" & I
If Not Dic.Exists(Keys) Then
Dic.Add Keys, I
dArr(I, 1) = "=" & Range("F" & I + 2).Address
Else
dArr(Dic.Item(Keys), 1) = dArr(Dic.Item(Keys), 1) & Range("J1") & Range("F" & I + 2).Address
End If
Next I
Range("H3").Resize(I - 1) = dArr
Set Dic = Nothing
End Sub
Upvote
0
♫ђöล♥ßล†♥†µ♫
Thành viên tiêu biểu
- Tham gia
- 10/3/18
- Bài viết
- 684
- Được thích
- 1,443
- Giới tính
- Nữ
- Nghề nghiệp
- Worksheet Function trong VBA , Thư viện mã lập trình, Scripting.Dictionary, Sổ tay VBA, Các hàm dò tìm và tham chiếu
Cuối cùng nó cũng chịu nghe lời
Mã:
Sub Nghich_ty_thoi()
Dim Dic As Object, Keys As String
Dim sArr(), dArr(), I As Long
Set Dic = CreateObject("Scripting.Dictionary")
sArr = Range("D10", Range("F" & Rows.Count).End(3)).Value
ReDim dArr(1 To UBound(sArr, 1), 1 To 1)
For I = 1 To UBound(sArr, 1)
If sArr(I, 1) = Empty Then Keys = "dong" & I
If Not Dic.Exists(Keys) Then
Dic.Add Keys, I
dArr(I, 1) = Replace("=" & Range("F" & I + 9).Address, "$", "")
Else
dArr(Dic.Item(Keys), 1) = Replace(dArr(Dic.Item(Keys), 1) & " & ""; "" & " & Range("F" & I + 9).Address, "$", "")
End If
Next I
Range("H10").Resize(I - 1) = dArr
Set Dic = Nothing
End Sub
Upvote
0
befaint
|||||||||||||
- Tham gia
- 6/1/11
- Bài viết
- 14,545
- Được thích
- 19,753
Cái này mình nói vài lần... Cách nhớ là "gõ bồi".
Mắc ở dấu 2 nháy thôi, mình gõ bồi: 2 dấu liên tiếp thì được 1 dấu. Tức là: & ""; "" & (1)
Rồi đem kết quả cho vào trong 2 dấu 2 nháy (quy tắc gán một chuỗi thông thường): chuoi = " (1) " = "& ""; "" &"
Upvote
0
vova2209
Thành viên tích cực
- Tham gia
- 5/4/17
- Bài viết
- 835
- Được thích
- 112
- Giới tính
- Nam
- Nghề nghiệp
- Đường bộ
Chị ơi! Thay đổi cột dữ liệu là sửa code nào chỉ nhỉ
Mã:
Sub Nghich_ty_thoi()
Dim Dic As Object, Keys As String
Dim sArr(), dArr(), I As Long
Set Dic = CreateObject("Scripting.Dictionary")
'D3 là lây' du~ liêu tu` dòng 3 di xuông'
sArr = Range("D3", Range("F" & Rows.Count).End(xlUp)).Value 'Côt D Diêu` kiên
ReDim dArr(1 To UBound(sArr, 1), 1 To 1)
For I = 1 To UBound(sArr, 1)
If sArr(I, 1) = Empty Then Keys = "dong" & I
If Not Dic.Exists(Keys) Then
Dic.Add Keys, I
dArr(I, 1) = sArr(I, 3)
Else
dArr(Dic.Item(Keys), 1) = dArr(Dic.Item(Keys), 1) & "; " & sArr(I, 3)
End If
Next I
'BB3 là xuât' du~ liêu vào dòng 3 di xuông'
Range("BB3").Resize(I - 1) = dArr 'Côt xuât' ra du liêu
Set Dic = Nothing
End Sub
Upvote
0
vova2209
Thành viên tích cực
- Tham gia
- 5/4/17
- Bài viết
- 835
- Được thích
- 112
- Giới tính
- Nam
- Nghề nghiệp
- Đường bộ
Em tìm được cách lấy giữ liệu cột khác rồi!
Cho em hỏi thêm 1 xíu nữa:
+ Thêm 1 điều kiện nữa nếu tên trùng nhau nó sẽ bỏ qua và lấy các tên khác với điều kiện dữ liệu cột D như phần trên
1. VD như hình ảnh dưới dòng 28~30 Đắp đất 10, nên chỉ lấy Đắp đất 10; Đắp đất 13
Và nếu dòng đầu không có dữ liệu nó lại thừa dấu " ; "
Cho em hỏi thêm 1 xíu nữa:
+ Thêm 1 điều kiện nữa nếu tên trùng nhau nó sẽ bỏ qua và lấy các tên khác với điều kiện dữ liệu cột D như phần trên
1. VD như hình ảnh dưới dòng 28~30 Đắp đất 10, nên chỉ lấy Đắp đất 10; Đắp đất 13
Và nếu dòng đầu không có dữ liệu nó lại thừa dấu " ; "
Mã:
Sub GopDuLieu_QTrinh()
Dim Dic As Object, Keys As String
Dim sArr(), dArr(), i As Long
Set Dic = CreateObject("Scripting.Dictionary")
'D3 là lây' du~ liêu tu` dòng 3 di xuông'
sArr = Range("D3", Range("AW" & Rows.Count).End(xlUp)).Value ' Diêu` kiên côt D & Vi trí Du Liêu côt AW
ReDim dArr(1 To UBound(sArr, 1), 1 To 1)
For i = 1 To UBound(sArr, 1)
If sArr(i, 1) = Empty Then Keys = "dong" & i
If Not Dic.Exists(Keys) Then
Dic.Add Keys, i
dArr(i, 1) = sArr(i, 46) 'Côt thú 46 tính tu` côt D là côt dâu` tiên
Else
dArr(Dic.Item(Keys), 1) = dArr(Dic.Item(Keys), 1) & "; " & sArr(i, 46) 'Côt thú 46 tính tu` côt D là côt dâu` tiên
End If
Next i
'BB3 là xuât' du~ liêu vào dòng 3 di xuông'
Range("BB3").Resize(i - 1) = dArr 'Côt xuât' ra du liêu
Set Dic = Nothing
End Sub
Lần chỉnh sửa cuối:
Upvote
0
♫ђöล♥ßล†♥†µ♫
Thành viên tiêu biểu
- Tham gia
- 10/3/18
- Bài viết
- 684
- Được thích
- 1,443
- Giới tính
- Nữ
- Nghề nghiệp
- Worksheet Function trong VBA , Thư viện mã lập trình, Scripting.Dictionary, Sổ tay VBA, Các hàm dò tìm và tham chiếu
Bạn thử cái này xem
Mã:
Sub GopDuLieu_QTrinh()
Dim Dic As Object, Keys As String
Dim sArr(), dArr(), I As Long
Set Dic = CreateObject("Scripting.Dictionary")
sArr = Range("D3", Range("AW" & Rows.Count).End(xlUp)).Value
ReDim dArr(1 To UBound(sArr, 1), 1 To 1)
For I = 1 To UBound(sArr, 1)
If sArr(I, 1) = Empty Then Keys = "dong" & I
If Not Dic.Exists(Keys) Then
Dic.Add Keys, I
dArr(I, 1) = sArr(I, 46)
Else
If InStrRev(dArr(Dic.Item(Keys), 1), sArr(I, 46)) = 0 Then
If dArr(Dic.Item(Keys), 1) <> Empty Then
dArr(Dic.Item(Keys), 1) = dArr(Dic.Item(Keys), 1) & "; " & sArr(I, 46)
Else
dArr(Dic.Item(Keys), 1) = sArr(I, 46)
End If
End If
End If
Next I
Range("BB3").Resize(I - 1) = dArr
Set Dic = Nothing
End Sub
Upvote
0
Mộng Thường 2001
Thành viên tiêu biểu
- Tham gia
- 28/11/17
- Bài viết
- 612
- Được thích
- 1,624
Chị này vừa đẹp, lại vừa tốt bụng nhiệt tình giúp đỡ toàn việc hữu ích cho anh chị em khác lâu nay trên diễn đàn rồi!
Giờ bạn mới biết cũng không có gì là lạ!
hihi ^o^
Upvote
0
Bài viết mới nhất
- Question
- Question
- Question
- Đã giải quyết
