Lấy dữ liệu bằng vba

tuan16 · 28/9/20

Hiện tại em có file excell sau ạ. Các ô chứa dữ liệu đang ở các vị trí cách quãng nhau và không theo quy luật ạ. Em muốn lấy các dữ liệu như em trình bày trong file ạ. Em có dùng công thức mảng để làm được nhưng file bị nặng. Em xin nhờ các anh chị trên diễn đàn viết giúp em đoạn code để em lấy được dữ liệu như mong muốn ạ.

SA_DQ · 28/9/20

Macro này sẽ thỏa iêu cầu của bạn:

PHP:

Sub LayDuLieuBangVBA()
 Dim Rng As Range, sRng As Range
 Dim Rws As Long, W As Integer, MaxNum As Integer, MinNum As Integer
 
 Set Rng = Range([B1], [B65500].End(xlUp))
 MaxNum = Application.WorksheetFunction.Max(Rng)
 MinNum = Application.WorksheetFunction.Min(Rng)
 [D4].CurrentRegion.Offset(1).Clear
 Randomize
 For W = MinNum To MaxNum
    Set sRng = Rng.Find(W, , xlFormulas, xlWhole)
    If Not sRng Is Nothing Then
        With [D65500].End(xlUp).Offset(1)
            .Value = W
            .Interior.ColorIndex = 34 + 9 * Rnd() \ 1
        End With
    End If
 Next W
End Sub

tuan16 · 28/9/20

SA_DQ đã viết:

Macro này sẽ thỏa iêu cầu của bạn:

PHP:

Sub LayDuLieuBangVBA()
Dim Rng As Range, sRng As Range
Dim Rws As Long, W As Integer, MaxNum As Integer, MinNum As Integer

Set Rng = Range([B1], [B65500].End(xlUp))
MaxNum = Application.WorksheetFunction.Max(Rng)
MinNum = Application.WorksheetFunction.Min(Rng)
[D4].CurrentRegion.Offset(1).Clear
Randomize
For W = MinNum To MaxNum
    Set sRng = Rng.Find(W, , xlFormulas, xlWhole)
    If Not sRng Is Nothing Then
        With [D65500].End(xlUp).Offset(1)
            .Value = W
            .Interior.ColorIndex = 34 + 9 * Rnd() \ 1
        End With
    End If
Next W
End Sub

Dạ em cảm ơn bác ạ

phulien1902 · 28/9/20

tuan16 đã viết:
Hiện tại em có file excell sau ạ. Các ô chứa dữ liệu đang ở các vị trí cách quãng nhau và không theo quy luật ạ. Em muốn lấy các dữ liệu như em trình bày trong file ạ. Em có dùng công thức mảng để làm được nhưng file bị nặng. Em xin nhờ các anh chị trên diễn đàn viết giúp em đoạn code để em lấy được dữ liệu như mong muốn ạ.

Cách khác:

PHP:

    Selection.SpecialCells(xlCellTypeConstants, 3).Copy Range("D4")
    Application.CutCopyMode = False

tuan16 · 28/9/20

phulien1902 đã viết:
Cách khác:

PHP:

Sub Test() Selection.SpecialCells(xlCellTypeConstants, 3).Copy Range("D4") Application.CutCopyMode = False End Sub

Dạ em cảm ơn. Em hỏi thêm chút. Trong trường hợp dữ liệu lúc đầu và dữ liệu mong muốn ở hai sheet khác nhau thì đoạn code trên cần chỉnh sửa gì ạ. Bác chỉ giúp em với ạ

Bài đã được tự động gộp: 28/9/20

SA_DQ đã viết:

Macro này sẽ thỏa iêu cầu của bạn:

PHP:

Sub LayDuLieuBangVBA()
Dim Rng As Range, sRng As Range
Dim Rws As Long, W As Integer, MaxNum As Integer, MinNum As Integer

Set Rng = Range([B1], [B65500].End(xlUp))
MaxNum = Application.WorksheetFunction.Max(Rng)
MinNum = Application.WorksheetFunction.Min(Rng)
[D4].CurrentRegion.Offset(1).Clear
Randomize
For W = MinNum To MaxNum
    Set sRng = Rng.Find(W, , xlFormulas, xlWhole)
    If Not sRng Is Nothing Then
        With [D65500].End(xlUp).Offset(1)
            .Value = W
            .Interior.ColorIndex = 34 + 9 * Rnd() \ 1
        End With
    End If
Next W
End Sub

Dạ dữ liệu đầu vào và dữ liệu mong muốn ở 2 sheet khác nhau thì chỉnh sửa đoạn code trên sao ạ. Cái này là sai sót của em không ghi vào từ đầu. Mong bác giúp ạ

phulien1902 · 28/9/20

tuan16 đã viết:
Dạ em cảm ơn. Em hỏi thêm chút. Trong trường hợp dữ liệu lúc đầu và dữ liệu mong muốn ở hai sheet khác nhau thì đoạn code trên cần chỉnh sửa gì ạ. Bác chỉ giúp em với ạ

Bài đã được tự động gộp: 28/9/20

Dạ dữ liệu đầu vào và dữ liệu mong muốn ở 2 sheet khác nhau thì chỉnh sửa đoạn code trên sao ạ. Cái này là sai sót của em không ghi vào từ đầu. Mong bác giúp ạ

Ví dụ:

PHP:

    With Sheet1
        ' Sheet1 dau vao
        'Sheet2 la sheet dau ra
        .Select
        .Range("B4:B22").SpecialCells(xlCellTypeConstants, 3).Copy Sheet2.Range("D4")
    End With
    Application.CutCopyMode = False

tuan16 · 28/9/20

phulien1902 đã viết:

Ví dụ:

PHP:

Sub Test2()
    With Sheet1
        ' Sheet1 dau vao
        'Sheet2 la sheet dau ra
        .Select
        .Range("B4:B22").SpecialCells(xlCellTypeConstants, 3).Copy Sheet2.Range("D4")
    End With
    Application.CutCopyMode = False
End Sub

Dạ nhanh quá ạ. Em cảm ơn.

tuan16 · 29/9/20

SA_DQ đã viết:

Macro này sẽ thỏa iêu cầu của bạn:

PHP:

Sub LayDuLieuBangVBA()
Dim Rng As Range, sRng As Range
Dim Rws As Long, W As Integer, MaxNum As Integer, MinNum As Integer

Set Rng = Range([B1], [B65500].End(xlUp))
MaxNum = Application.WorksheetFunction.Max(Rng)
MinNum = Application.WorksheetFunction.Min(Rng)
[D4].CurrentRegion.Offset(1).Clear
Randomize
For W = MinNum To MaxNum
    Set sRng = Rng.Find(W, , xlFormulas, xlWhole)
    If Not sRng Is Nothing Then
        With [D65500].End(xlUp).Offset(1)
            .Value = W
            .Interior.ColorIndex = 34 + 9 * Rnd() \ 1
        End With
    End If
Next W
End Sub

dạ sáng nay em có thử đoạn code của bác thì chưa ra kết quả như ý muốn ạ... bác xem trong trường hợp dữ liệu ban đầu và dữ liệu mong muốn ở hai sheet khác nhau thì bác sửa giúp em đoạn cođe trên với ạ . bỏ cả phần tô màu nữa với ạ

Bài đã được tự động gộp: 29/9/20

tuan16 đã viết:
Dạ nhanh quá ạ. Em cảm ơn.

dạ bác ơi. kết quả không ra như mong muốn. bác xem giúp lỗi ở đâu em với ạ

SA_DQ · 29/9/20

tuan16 đã viết:
(1) dạ sáng nay em có thử đoạn code của bác thì chưa ra kết quả như ý muốn ạ...
(2) bác xem trong trường hợp dữ liệu ban đầu và dữ liệu mong muốn ở hai sheet khác nhau thì bác sửa giúp em đoạn cođe trên với ạ . bỏ cả phần tô màu nữa với ạ

(1) Thiết nghĩ macro mình viết thỏa mong muốn (+) ở #1 của bạn; Bạn nói xem kết quả nào mới như mong muốn;

(2) Sau khi giải quyết (1)

tuan16 · 29/9/20

SA_DQ đã viết:
(1) Thiết nghĩ macro mình viết thỏa mong muốn (+) ở #1 của bạn; Bạn nói xem kết quả nào mới như mong muốn;

(2) Sau khi giải quyết (1)

đây ạ...nhờ bác xem thêm cho 1 lần nữa với ạ

be_09 · 29/9/20

tuan16 đã viết:
dạ sáng nay em có thử đoạn code của bác thì chưa ra kết quả như ý muốn ạ... bác xem trong trường hợp dữ liệu ban đầu và dữ liệu mong muốn ở hai sheet khác nhau thì bác sửa giúp em đoạn cođe trên với ạ . bỏ cả phần tô màu nữa với ạ
dạ bác ơi. kết quả không ra như mong muốn. bác xem giúp lỗi ở đâu em với ạ

Nếu chỉ copy Sheet1 sang Sheet2 thì chỉ vầy thôi:
Còn cái vụ tô màu theo giá trị thì phải có bảng tra.

Mã:

Sub Copy()
Sheet1.Range("B4:B5000").SpecialCells(xlCellTypeConstants, 1).Copy Sheet2.Range("D4")
End Sub

tuan16 · 29/9/20

be09 đã viết:
Nếu chỉ copy Sheet1 sang Sheet2 thì chỉ vầy thôi:
Còn cái vụ tô màu theo giá trị thì phải có bảng tra.

Mã:

Sub Copy() Sheet1.Range("B4:B5000").SpecialCells(xlCellTypeConstants, 1).Copy Sheet2.Range("D4") End Sub

em có thử đoạn code của bác ạ.dạ đúng rồi ạ... em cảm ơn ạ

tuan16 · 29/9/20

tuan16 đã viết:
em có thử đoạn code của bác ạ.dạ đúng rồi ạ... em cảm ơn ạ

dạ em hỏi thêm chút nữa. đoạn code trên sao không chạy được với các ký tự là chữ ạ.. ví dụ 1,5,3 em thay bằng a,c,b thì lại không được

phulien1902 · 29/9/20

tuan16 đã viết:
dạ em hỏi thêm chút nữa. đoạn code trên sao không chạy được với các ký tự là chữ ạ.. ví dụ 1,5,3 em thay bằng a,c,b thì lại không được

Bạn thay:

PHP:

SpecialCells(xlCellTypeConstants, 3)

bằng:

PHP:

SpecialCells(xlCellTypeConstants, 2)

Chú ý:
+ Số 1( lấy số)
+ Số 2( lấy chữ)
+ Số 3( lấy cả chữ và số)

be_09 · 29/9/20

tuan16 đã viết:
dạ em hỏi thêm chút nữa. đoạn code trên sao không chạy được với các ký tự là chữ ạ.. ví dụ 1,5,3 em thay bằng a,c,b thì lại không được

Sửa số 1 trong code trên thành số 3 để copy vừa Text và số.

Phamvannhan1531 · 29/9/20

be09 đã viết:
Sửa số 1 trong code trên thành số 3 để copy vừa Text và số.

Em có bài toán tương tự chủ thớt và xin áp dụng đoạn code của bác nhưng báo lỗi ạ. em xin nhờ các chỉnh sửa giúp em với ạ

phulien1902 · 29/9/20

Bạn thử:

PHP:

   Dim a(), b(), i&, k%, LR
    With Sheets("dau vao")
        a = .Range("A8", .Range("A100000").End(3)).Resize(, 3).Value: LR = UBound(a)
    End With
    ReDim b(1 To LR, 1 To 1)
    With Sheets("dau vao")
        For i = 1 To LR
            If IsDate(a(i, 2)) <> Empty Then
                k = k + 1: b(k, 1) = a(i, 3)
            End If
        Next i
        If k Then
            With Sheets("ket qua")
                .Range("D8:D100").ClearContents
                .Range("D8").Resize(k) = b
            End With
        End If
    End With

Phamvannhan1531 · 29/9/20

phulien1902 đã viết:

Bạn thử:

PHP:

   Dim a(), b(), i&, k%, LR
    With Sheets("dau vao")
        a = .Range("A8", .Range("A100000").End(3)).Resize(, 3).Value: LR = UBound(a)
    End With
    ReDim b(1 To LR, 1 To 1)
    With Sheets("dau vao")
        For i = 1 To LR
            If IsDate(a(i, 2)) <> Empty Then
                k = k + 1: b(k, 1) = a(i, 3)
            End If
        Next i
        If k Then
            With Sheets("ket qua")
                .Range("D8:D100").ClearContents
                .Range("D8").Resize(k) = b
            End With
        End If
    End With

Dạ bác giúp em có phím tắt như button để mình kích nhanh cho kết quả với ạ. Với đoạn code bác cho em không biết sử dụng như nào.

phulien1902 · 29/9/20

Phamvannhan1531 đã viết:
Dạ bác giúp em có phím tắt như button để mình kích nhanh cho kết quả với ạ. Với đoạn code bác cho em không biết sử dụng như nào.

Bạn Click vào Button nhé.

Phamvannhan1531 · 29/9/20

phulien1902 đã viết:
Bạn Click vào Button nhé.

chính xác luôn ạ. bác giỏi quá

Lấy dữ liệu bằng vba

Thành viên thường trực

File đính kèm

/(hông là gì!

Thành viên thường trực

GPE - My love

Thành viên thường trực

GPE - My love

Thành viên thường trực

Thành viên thường trực

File đính kèm

/(hông là gì!

Thành viên thường trực

File đính kèm

Biên Hòa, Đồng Nai

Thành viên thường trực

Thành viên thường trực

GPE - My love

Biên Hòa, Đồng Nai

Thành viên mới

File đính kèm

GPE - My love

Thành viên mới

GPE - My love

File đính kèm

Thành viên mới