gộp 2 sub thành 1 sub (1 người xem)

DMQ · 26/2/14

Mong các AC giúp em gộp code của sub XOA vô SUB BaoCaoNhapXuatTon. Chỉnh dùm em khi SUB BâoCoNhapXuatTon chạy thì giữ luôn định dạng của các sheet chi tiết(như đường kẻ,màu,phân cách của số...) Code này là của Anh Vodoi2x làm cho em(Mong Anh, và Các AC có thể giúp em)

Sub XOA()
Range("KETQUA").Offset(1).Resize(6000, idTonCK).ClearContents
End Sub
Sub BaoCaoNhapXuatTon()
Application.ScreenUpdating = False
''Nap cac Du lieu nhap
Dim DmvTon(), MhNhap(), ddNhap(), SlgNhap(), MhXuat(), SlgXuat(), ddXuat()
Dim nDM As Long, nNhap As Long, nXuat As Long, nRes As Long
Dim Dic, arNXT(), aAdd()
Dim I As Long, K As Long, ddFr As Long, ddTo As Long, ik As ColRes

'Nhap cac du lieu Danh muc Hang Hoa va TonDau
With Range("DMvTON")
If .Offset(1).Value <> "" Then
DmvTon = Range(.Offset(1), .Offset(1).End(xlDown)).Resize(, 4).Value2
nDM = UBound(DmvTon)
Else
MsgBox "Xem lai Du lieu Danh muc va Ton", vbOKOnly + vbCritical, "Danh muc va Ton"
Exit Sub
End If
End With

'Nhap Du lieu NHAP
With Range("NHAP")
If .Offset(1).Value <> "" Then
MhNhap = Range(.Offset(1), .End(xlDown)).Value2
nNhap = UBound(MhNhap)
SlgNhap = .Offset(1, 4).Resize(nNhap).Value2
ddNhap = .Offset(1, -2).Resize(nNhap).Value2
Else
MsgBox "Xem lai Du lieu chung tu NHAP", vbOKOnly + vbCritical, "Chung tu Nhap"
Exit Sub
End If
End With

'Nhap Du lieu XUAT
With Range("XUAT")
If .Offset(1).Value <> "" Then
MhXuat = Range(.Offset(1), .End(xlDown)).Value2
nXuat = UBound(MhXuat)
SlgXuat = .Offset(1, 4).Resize(nXuat).Value2
ddXuat = .Offset(1, -4).Resize(nXuat).Value2
Else
MsgBox "Xem lai Du lieu chung tu XUAT", vbOKOnly + vbCritical, "Chung tu Xuat"
Exit Sub
End If
End With

'Nhap Du lieu Tu Ngay -> Den Ngay
ddFr = Range("TUNGAY").Value2
ddTo = Range("DENNGAY").Value2

Set Dic = CreateObject("Scripting.Dictionary")
For I = 1 To nDM
Dic(DmvTon(I, 1)) = I
Next I

ReDim arNXT(1 To nDM + 10, idTonDK To idXuat)

For I = 1 To nDM
arNXT(I, idTonDK) = DmvTon(I, 4)
Next I

ReDim Preserve aAdd(1 To 1)
nRes = nDM
For I = 1 To nNhap
If ddNhap(I, 1) <= ddTo Then
K = Dic(MhNhap(I, 1))
If K = 0 Then
nRes = nRes + 1: K = nRes: Dic(MhNhap(I, 1)) = K
ReDim Preserve aAdd(1 To nRes - nDM): aAdd(nRes - nDM) = MhNhap(I, 1)
End If

If ddNhap(I, 1) < ddFr Then 'ton
arNXT(K, idTonDK) = arNXT(K, idTonDK) + SlgNhap(I, 1)
Else 'trong ky
arNXT(K, idNhap) = arNXT(K, idNhap) + SlgNhap(I, 1)
End If
End If
Next I

For I = 1 To nXuat
If ddXuat(I, 1) <= ddTo Then
K = Dic(MhXuat(I, 1))
If K = 0 Then
nRes = nRes + 1: K = nRes: Dic(MhXuat(I, 1)) = K
ReDim Preserve aAdd(1 To nRes - nDM): aAdd(nRes - nDM) = MhXuat(I, 1)
End If

If ddXuat(I, 1) < ddFr Then 'ton
arNXT(K, idTonDK) = arNXT(K, idTonDK) - SlgXuat(I, 1)
Else 'trong ky
arNXT(K, idXuat) = arNXT(K, idXuat) + SlgXuat(I, 1)
End If
End If
Next I

Call XOA
With Range("KETQUA").Offset(1)
K = -1
For I = 1 To nRes
If arNXT(I, idTonDK) <> 0 Or arNXT(I, idNhap) <> 0 Or arNXT(I, idXuat) <> 0 Then
K = K + 1
.Offset(K, idNo - 1).Value = K + 1
If I <= nDM Then
.Offset(K, idMaHang - 1) = DmvTon(I, 1)
.Offset(K, idTenHang - 1) = DmvTon(I, 2)
.Offset(K, idDVT - 1) = DmvTon(I, 3)
Else
.Offset(K, idMaHang - 1) = aAdd(I - nDM)
End If

For ik = idTonDK To idXuat
.Offset(K, ik - 1) = arNXT(I, ik)
Next
.Offset(K, idTonCK - 1) = arNXT(I, idTonDK) + arNXT(I, idNhap) - arNXT(I, idXuat)
End If
Next I
End With
K = K + 1
Application.ScreenUpdating = True

If nRes > nDM Then
MsgBox "Chuong trinh ket thuc" _
& vbLf & "co tat ca " & K & " ma hang duoc tinh NXT" _
& vbLf & vbLf & "Co " & nRes - nDM & " mat hang cuoi chua co trong Danh muc", _
vbOKOnly + vbCritical, "THONG BAO"
Else
MsgBox "Chuong trinh ket thuc" _
& vbLf & "co tat ca " & K & " ma hang duoc tinh NXT", _
vbOKOnly, "THONG BAO"
End If
End Sub

phucbugis · 26/2/14

sau khi nhập xong thì lấy file ở đâu mà test vậy bạn? :-=

DMQ · 26/2/14

File đây ah!!!! Mong các AC giúp đỡ.

DMQ · 27/2/14

Chổ Call XOA em thay bằng code của SUB XOA được không các ANH????

SA_DQ · 27/2/14

Hoàn toàn được, mình nghỉ vậy

Chổ Call XOA em thay bằng code của SUB XOA được không các ANH????

Nhưng rất ngại trả lời 1 khi ngó vô đám rừng hoang vu mà khiếp
Vầy đỡ chóng mặt hơn nè:

PHP:

Option Explicit
Sub BaoCaoNhapXuatTon()
Application.ScreenUpdating = False
'Nap cac Du lieu nhap'
 Dim DmvTon(), MhNhap(), ddNhap(), SlgNhap(), MhXuat(), SlgXuat(), ddXuat()
 Dim nDM As Long, nNhap As Long, nXuat As Long, nRes As Long
 Dim Dic, arNXT(), aAdd()
 Dim I As Long, K As Long, ddFr As Long, ddTo As Long, ik As ColRes
'Nhap Các Du Lieu Danh Muc Hàng Hóa & TonDauD'
 With Range("DMvTON")
    If .Offset(1).Value <> "" Then
        DmvTon = Range(.Offset(1), .Offset(1).End(xlDown)).Resize(, 4).Value2
        nDM = UBound(DmvTon)
    Else
        MsgBox "Xem lai Du lieu Danh muc va Ton", vbOKOnly + vbCritical, "Danh muc & Ton"
        Exit Sub
    End If
 End With
'Nhap Du lieu NHAP'
 With Range("NHAP")
    If .Offset(1).Value <> "" Then
        MhNhap = Range(.Offset(1), .End(xlDown)).Value2
        nNhap = UBound(MhNhap)
        SlgNhap = .Offset(1, 4).Resize(nNhap).Value2
        ddNhap = .Offset(1, -2).Resize(nNhap).Value2
    Else
        MsgBox "Xem lai Du lieu chung tu NHAP", vbOKOnly + vbCritical, "Chung tu Nhap"
        Exit Sub
    End If
 End With
'Nhap Du lieu XUAT'
 With Range("XUAT")
    If .Offset(1).Value <> "" Then
        MhXuat = Range(.Offset(1), .End(xlDown)).Value2
        nXuat = UBound(MhXuat)
        SlgXuat = .Offset(1, 4).Resize(nXuat).Value2
        ddXuat = .Offset(1, -4).Resize(nXuat).Value2
    Else
        MsgBox "Xem lai Du lieu chung tu XUAT", vbOKOnly + vbCritical, "Chung tu Xuat"
        Exit Sub
    End If
 End With
'Nhap Du lieu Tù Ngày -> Dén Ngày'
 ddFr = Range("TUNGAY").Value2
 ddTo = Range("DENNGAY").Value2

 Set Dic = CreateObject("Scripting.Dictionary")
 For I = 1 To nDM
    Dic(DmvTon(I, 1)) = I
 Next I
 ReDim arNXT(1 To nDM + 10, idTonDK To idXuat)
 For I = 1 To nDM
    arNXT(I, idTonDK) = DmvTon(I, 4)
 Next I
 ReDim Preserve aAdd(1 To 1)
 nRes = nDM
 For I = 1 To nNhap
    If ddNhap(I, 1) <= ddTo Then
        K = Dic(MhNhap(I, 1))
        If K = 0 Then
            nRes = nRes + 1: K = nRes: Dic(MhNhap(I, 1)) = K
            ReDim Preserve aAdd(1 To nRes - nDM): aAdd(nRes - nDM) = MhNhap(I, 1)
        End If
        If ddNhap(I, 1) < ddFr Then 'ton'
            arNXT(K, idTonDK) = arNXT(K, idTonDK) + SlgNhap(I, 1)
        Else        'Trong Kì '
            arNXT(K, idNhap) = arNXT(K, idNhap) + SlgNhap(I, 1)
        End If
    End If
 Next I
 For I = 1 To nXuat
    If ddXuat(I, 1) <= ddTo Then
        K = Dic(MhXuat(I, 1))
        If K = 0 Then
            nRes = nRes + 1: K = nRes: Dic(MhXuat(I, 1)) = K
            ReDim Preserve aAdd(1 To nRes - nDM): aAdd(nRes - nDM) = MhXuat(I, 1)
        End If

        If ddXuat(I, 1) < ddFr Then 'ton'
            arNXT(K, idTonDK) = arNXT(K, idTonDK) - SlgXuat(I, 1)
        Else 'trong ky '
            arNXT(K, idXuat) = arNXT(K, idXuat) + SlgXuat(I, 1)
        End If
    End If
 Next I
    Call XOA
 With Range("KETQUA").Offset(1)
    K = -1
    For I = 1 To nRes
        If arNXT(I, idTonDK) <> 0 Or arNXT(I, idNhap) <> 0 Or arNXT(I, idXuat) <> 0 Then
            K = K + 1
            .Offset(K, idNo - 1).Value = K + 1
            If I <= nDM Then
                .Offset(K, idMaHang - 1) = DmvTon(I, 1)
                .Offset(K, idTenHang - 1) = DmvTon(I, 2)
                .Offset(K, idDVT - 1) = DmvTon(I, 3)
            Else
                .Offset(K, idMaHang - 1) = aAdd(I - nDM)
            End If

            For ik = idTonDK To idXuat
                .Offset(K, ik - 1) = arNXT(I, ik)
            Next
            .Offset(K, idTonCK - 1) = arNXT(I, idTonDK) + arNXT(I, idNhap) - arNXT(I, idXuat)
        End If
    Next I
 End With
 K = K + 1
 Application.ScreenUpdating = True

 If nRes > nDM Then
    MsgBox "Chuong trinh ket thuc" _
        & vbLf & "co tat ca " & K & " ma hang duoc tinh NXT" _
            & vbLf & vbLf & "Co " & nRes - nDM & " mat hang cuoi chua co trong Danh muc", _
                vbOKOnly + vbCritical, "THONG BAO"
 Else
    MsgBox "Chuong trinh ket thuc" _
        & vbLf & "co tat ca " & K & " ma hang duoc tinh NXT", _
            vbOKOnly, "THONG BAO"
 End If
End Sub

DMQ · 27/2/14

Dạ được Thầy ơi!! Thầy Chỉ cho em cách chạy code thì giữ luôn định dạng của sheet chi tiết với(như đường viền định dạng của số, màu fill)

gộp 2 sub thành 1 sub (1 người xem)

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

DMQ

Thành viên dốt

phucbugis

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

DMQ

Thành viên dốt

File đính kèm

DMQ

Thành viên dốt

SA_DQ

/(hông là gì!

DMQ

Thành viên dốt

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

Thời gian đếm ngược.