GIúp code tách tên hàng thành nhiều tên tương ứng với Số lượng là 1 (1 người xem)

minhtuan55 · 2/5/18

Chào cả nhà GPE ! em có vấn đề như sau

Rất mong mọi người giúp đở. Xin chân thành cảm ơn

Hoang2013 · 3/5/18

PHP:

Const GPE As Long = 65500
Sub TáchḌng()
 ReDim Arr(1 To GPE, 1 To 2)
 Dim J As Long, W As Long, Num As Double, Rws As Long
 Dim TenHang As String
 
 [F7].Resize(65500, 2).Value = Arr()
 For J = 7 To [b7].End(xlDown).Row
    Num = Cells(J, "C").Value:              TenHang = Cells(J, "B").Value
    If Num <= 0 Then
        W = W + 1
        Arr(W, 1) = TenHang:                Arr(W, 2) = Num
    Else
        Do
            If Num - 1 >= 1 Then
                W = W + 1:                  Arr(W, 1) = TenHang
                Arr(W, 2) = 1:              Num = Num - 1
            Else             '*'
                W = W + 1:                  Arr(W, 1) = TenHang
                Arr(W, 2) = 1
                If Num > 1 Then
                    W = W + 1:              Arr(W, 1) = TenHang
                    Arr(W, 2) = Num - 1
                End If
                Exit Do
            End If
        Loop
    End If
 Next J
 If W Then
    [F7].Resize(W, 2).Value = Arr()
 End If
End Sub

minhtuan55 · 3/5/18

Hoang2013 đã viết:

PHP:

Const GPE As Long = 65500
Sub TáchḌng()
ReDim Arr(1 To GPE, 1 To 2)
Dim J As Long, W As Long, Num As Double, Rws As Long
Dim TenHang As String

[F7].Resize(65500, 2).Value = Arr()
For J = 7 To [b7].End(xlDown).Row
    Num = Cells(J, "C").Value:              TenHang = Cells(J, "B").Value
    If Num <= 0 Then
        W = W + 1
        Arr(W, 1) = TenHang:                Arr(W, 2) = Num
    Else
        Do
            If Num - 1 >= 1 Then
                W = W + 1:                  Arr(W, 1) = TenHang
                Arr(W, 2) = 1:              Num = Num - 1
            Else             '*'
                W = W + 1:                  Arr(W, 1) = TenHang
                Arr(W, 2) = 1
                If Num > 1 Then
                    W = W + 1:              Arr(W, 1) = TenHang
                    Arr(W, 2) = Num - 1
                End If
                Exit Do
            End If
        Loop
    End If
Next J
If W Then
    [F7].Resize(W, 2).Value = Arr()
End If
End Sub

Cảm ơn bác. Bác sữa lại code tí là khi SL <=0 thì không cần tách ra, hiện tại code của bác tách ra luôn

minhtuan55 · 3/5/18

Hoang2013 đã viết:

PHP:

Const GPE As Long = 65500
Sub TáchḌng()
ReDim Arr(1 To GPE, 1 To 2)
Dim J As Long, W As Long, Num As Double, Rws As Long
Dim TenHang As String

[F7].Resize(65500, 2).Value = Arr()
For J = 7 To [b7].End(xlDown).Row
    Num = Cells(J, "C").Value:              TenHang = Cells(J, "B").Value
    If Num <= 0 Then
        W = W + 1
        Arr(W, 1) = TenHang:                Arr(W, 2) = Num
    Else
        Do
            If Num - 1 >= 1 Then
                W = W + 1:                  Arr(W, 1) = TenHang
                Arr(W, 2) = 1:              Num = Num - 1
            Else             '*'
                W = W + 1:                  Arr(W, 1) = TenHang
                Arr(W, 2) = 1
                If Num > 1 Then
                    W = W + 1:              Arr(W, 1) = TenHang
                    Arr(W, 2) = Num - 1
                End If
                Exit Do
            End If
        Loop
    End If
Next J
If W Then
    [F7].Resize(W, 2).Value = Arr()
End If
End Sub

bác sữa lại cho em chưa. Em muốn SL<=0 không cần phải tách ra. Chứ bác làm vậy mắc công em Phải mất thêm 1 công đoạn lọc nữa

Hoang2013 · 3/5/18

Hiện macro cho kết qủa vày nè; hay là bạn muốn sao khác?

♫ђöล♥ßล†♥†µ♫ · 3/5/18

minhtuan55 đã viết:
bác sữa lại cho em chưa. Em muốn SL<=0 không cần phải tách ra. Chứ bác làm vậy mắc công em Phải mất thêm 1 công đoạn lọc nữa

Sao học sinh ở chỗ anh mua sách giáo khoa mà mua có 0.5 quyển vậy nhỉ. Không biết 0.5 quyển còn lại để làm gì

HTML:

Sub Tach()
ReDim Arr(1 To GPE, 1 To 2)
    Dim J As Long, W As Long, Num As Double, Rws As Long
    Dim TenHang As String
[F7].Resize(65500, 2).Value = Arr()
For J = 7 To [b7].End(xlDown).Row
    Num = Cells(J, "C").Value:              TenHang = Cells(J, "B").Value
    If Num > 0 Then
        Do
            If Num - 1 >= 1 Then
                W = W + 1:                  Arr(W, 1) = TenHang
                Arr(W, 2) = 1:              Num = Num - 1
                Else             '*'
                W = W + 1:                  Arr(W, 1) = TenHang
                Arr(W, 2) = 1
                If Num > 1 Then
                    W = W + 1:              Arr(W, 1) = TenHang
                    Arr(W, 2) = Num - 1
                End If
                Exit Do
            End If
        Loop
    End If
Next J
If W Then
    [F7].Resize(W, 2).Value = Arr()
End If
End Sub

Hoang2013 · 3/5/18

Sao học sinh ở chỗ anh mua sách giáo khoa mà mua có 0.5 quyển vậy nhỉ. Không biết 0.5 quyển còn lại để làm gì

Khi SGK không còn trang 17 coi như còn nữa giá trị;
Nhiều nước khi xưa không cho những quyễn sách mất trang 17 ra khỏi nước mình; vậy đó!

Phuocam · 3/5/18

♫ђöล♥ßล†♥†µ♫ đã viết:
Sao học sinh ở chỗ anh mua sách giáo khoa mà mua có 0.5 quyển vậy nhỉ. Không biết 0.5 quyển còn lại để làm gì

Nửa cuốn còn lại là bí kíp võ lâm!

Mã:

Public Sub TachSoLuong()
Dim inputArr(), OutputArr()
Dim i As Long, J As Long, k As Long
Dim Num1 As Double, Num2 As Long
inputArr = Range("B7", Range("C" & Rows.Count).End(xlUp)).Value
ReDim OutputArr(1 To 100000, 1 To 2)
For i = 1 To UBound(inputArr)
    Num1 = inputArr(i, 2)
    If Num1 > 0 Then
        Num2 = Application.WorksheetFunction.Ceiling(Num1, 1)
         For J = 1 To Num2
            k = k + 1
            OutputArr(k, 1) = inputArr(i, 1)
                If J < Num2 Or Num1 = Num2 Then
                    OutputArr(k, 2) = 1
                Else
                    OutputArr(k, 2) = Num1 - Int(Num1)
                End If
        Next J
    End If
Next i
If k > 0 Then Range("F7").Resize(k, 2) = OutputArr
End Sub

ndu96081631 · 3/5/18

♫ђöล♥ßล†♥†µ♫ đã viết:
Sao học sinh ở chỗ anh mua sách giáo khoa mà mua có 0.5 quyển vậy nhỉ. Không biết 0.5 quyển còn lại để làm gì

Người ta chỉ giả lập file thôi mà! Có điều ví dụ này cũng hợp lý đóa nhoa, bởi nhiều khi người ta còn mua có 1 trang (cuối) chứ nửa quyển là nhiều rồi đó
----------------
ah! mà bài này nếu dùng 1 vòng lập thì được hôn ta?

befaint · 3/5/18

ndu96081631 đã viết:
ah! mà bài này nếu dùng 1 vòng lập thì được hôn ta?

Cứ thấy bài này là lại thấy câu này.

minhtuan55 · 3/5/18

Hoang2013 đã viết:
Hiện macro cho kết qủa vày nè; hay là bạn muốn sao khác?

Em muốn như câu hỏi em đó. Anh xẻm ảnh lài bài 1 của em đó. Em đã nói Nhưng ô nào có SL <=0 thì không cần phài xuất ra

minhtuan55 · 3/5/18

phuocam đã viết:

Nửa cuốn còn lại là bí kíp võ lâm!

Mã:

Public Sub TachSoLuong()
Dim inputArr(), OutputArr()
Dim i As Long, J As Long, k As Long
Dim Num1 As Double, Num2 As Long
inputArr = Range("B7", Range("C" & Rows.Count).End(xlUp)).Value
ReDim OutputArr(1 To 100000, 1 To 2)
For i = 1 To UBound(inputArr)
    Num1 = inputArr(i, 2)
    If Num1 > 0 Then
        Num2 = Application.WorksheetFunction.Ceiling(Num1, 1)
         For J = 1 To Num2
            k = k + 1
            OutputArr(k, 1) = inputArr(i, 1)
                If J < Num2 Or Num1 = Num2 Then
                    OutputArr(k, 2) = 1
                Else
                    OutputArr(k, 2) = Num1 - Int(Num1)
                End If
        Next J
    End If
Next i
If k > 0 Then Range("F7").Resize(k, 2) = OutputArr
End Sub

Code chính xác tuyệt đối

Hoang2013 · 3/5/18

minhtuan55 đã viết:
Em muốn như câu hỏi em đó. Anh xẻm ảnh lài bài 1 của em đó. Em đã nói Nhưng ô nào có SL <=0 thì không cần phài xuất ra

À hiểu rồi! Khi đó ta vô hiệu hóa 2 dòng lệnh này là được:

PHP:

    If Num <= 0 Then
'        W = W + 1                              '
'        Arr(W, 1) = TenHang:                Arr(W, 2) = Num           '

excel_lv1.5 · 3/5/18

ndu96081631 đã viết:
ah! mà bài này nếu dùng 1 vòng lập thì được hôn ta?

Cho tôi thử :

Mã:

Sub a()
Dim i As Long, rng, wf As WorksheetFunction
Set wf = WorksheetFunction
rng = Range("B7:C" & [B100000].End(xlUp).Row)
For i = 1 To UBound(rng)
    If rng(i, 2) > 0 Then
        [F100000].End(xlUp).Offset(1).Resize(wf.Ceiling(rng(i, 2), 1), 2) = Array(rng(i, 1), 1)
        [G100000].End(xlUp) = IIf(rng(i, 2) = wf.Floor(rng(i, 2), 1), 1, rng(i, 2) - wf.Floor(rng(i, 2), 1))
    End If
Next i
End Sub

minhtuan55 · 3/5/18

excel_lv1.5 đã viết:

Cho tôi thử :

Mã:

Sub a()
Dim i As Long, rng, wf As WorksheetFunction
Set wf = WorksheetFunction
rng = Range("B7:C" & [B100000].End(xlUp).Row)
For i = 1 To UBound(rng)
    If rng(i, 2) > 0 Then
        [F100000].End(xlUp).Offset(1).Resize(wf.Ceiling(rng(i, 2), 1), 2) = Array(rng(i, 1), 1)
        [G100000].End(xlUp) = IIf(rng(i, 2) = wf.Floor(rng(i, 2), 1), 1, rng(i, 2) - wf.Floor(rng(i, 2), 1))
    End If
Next i
End Sub

Code bác nếu trùng tên hàng thì không ra gì hết bác nhé. Cần sữa lại nếu trùng tên cũng tách ra bình thường

GIúp code tách tên hàng thành nhiều tên tương ứng với Số lượng là 1 (1 người xem)

Người dùng đang xem chủ đề này

minhtuan55

Thành viên bị đình chỉ hoạt động

File đính kèm

Hoang2013

Thành viên gắn bó

minhtuan55

Thành viên bị đình chỉ hoạt động

minhtuan55

Thành viên bị đình chỉ hoạt động

Hoang2013

Thành viên gắn bó

File đính kèm

♫ђöล♥ßล†♥†µ♫

Thành viên tiêu biểu

Hoang2013

Thành viên gắn bó

Phuocam

Thành viên mới

ndu96081631

Huyền thoại GPE

befaint

|||||||||||||

minhtuan55

Thành viên bị đình chỉ hoạt động

minhtuan55

Thành viên bị đình chỉ hoạt động

Hoang2013

Thành viên gắn bó

excel_lv1.5

Thành viên tích cực

minhtuan55

Thành viên bị đình chỉ hoạt động

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

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

Đếm ngược thời gian