Thống kê vật tư từ các biên bản bàn giao tài sản trên phần mềm

Blue Softs Liên hệ QC

quyenpv

Thu nhặt kiến thức
Tham gia
5/1/13
Bài viết
546
Được thích
73
Giới tính
Nam
Nghề nghiệp
Decode cuộc đời!
Kính gửi các anh chị!
Lại một lần nữa em làm phiền anh chị, mong các anh chị giúp đỡ em với ạ do các công việc hiện tại em đang làm bằng tay dẫn đến sai sót nhiều
Hiện em đang làm xuất các tài sản trên phần mềm quản lý hạ tầng mạng lưới theo từng mã ra từng file riêng biệt, nhu cầu em cần thống kê từ các file đó vào 1 file tổng hợp theo cấu hình có sẵn để dùng cho nhiều mục đích khác nhau
Yêu cầu:
1. Cho phép chọn một hay nhiều file tự động thống kê số lượng vật tư (Cột J), đơn giá (Cột K) theo mã vật tư (Cột C) vào file tổng hợp Input_TBi
2. Ý tưởng của em nếu mã vật tư có xuất hiện nhiều hơn một lần thì liệt kê sang cột tiếp theo bao gồm cả khối lượng và đơn giá
3. Nhờ anh chị viết code VBA để giảm thiểu nặng file ạ
Cám ơn các anh chị đã quan tâm giúp đỡ em, mong anh chị hỗ trợ với ạ
Em cám ơn
Em có làm tay 2 mã vật tư để diễn giải ý tưởng của em như hình sau ạ
Trong Sheet Input_TB
1632816249627.png
Trong file xuất ra từ phần mềm
1632814291902.png
 

File đính kèm

  • 1632814240471.png
    1632814240471.png
    116.6 KB · Đọc: 14
  • 1632814249735.png
    1632814249735.png
    116.6 KB · Đọc: 4
  • BCTKTSTDV_3VT139_1632793410307.xls
    87.5 KB · Đọc: 4
  • BCTKTSTDV_eVT00139_1632793442986.xls
    75 KB · Đọc: 3
  • BCTKTSTDV_VTU139_1632793361322.xls
    152.5 KB · Đọc: 4
  • Help_Thong Ke Vat tu.xlsx
    131.6 KB · Đọc: 5
Lần chỉnh sửa cuối:

quyenpv

Thu nhặt kiến thức
Tham gia
5/1/13
Bài viết
546
Được thích
73
Giới tính
Nam
Nghề nghiệp
Decode cuộc đời!
Các anh chị xem giúp em với nhé. Cám ơn
 
Upvote 0

HieuCD

Chuyên gia GPE
Tham gia
14/9/10
Bài viết
8,477
Được thích
17,769
Kính gửi các anh chị!
Lại một lần nữa em làm phiền anh chị, mong các anh chị giúp đỡ em với ạ do các công việc hiện tại em đang làm bằng tay dẫn đến sai sót nhiều
Hiện em đang làm xuất các tài sản trên phần mềm quản lý hạ tầng mạng lưới theo từng mã ra từng file riêng biệt, nhu cầu em cần thống kê từ các file đó vào 1 file tổng hợp theo cấu hình có sẵn để dùng cho nhiều mục đích khác nhau
Kiểm tra lại
Mã:
Option Explicit
Sub XYZ()
  Dim dic As Object, cn As Object, rs As Object, FileItem, ListFile As Object
  Dim sArr(), arr, res(), sRow&, i&, j&, iR&
 
  Set ListFile = GetFile("")
  If ListFile Is Nothing Then MsgBox "Chua chon File, thoat Sub ": Exit Sub
  sArr = Range("C17", Range("C" & Rows.Count).End(xlUp)).Value
  sRow = UBound(sArr)
  ReDim res(1 To sRow, 1 To 24)
  Set dic = CreateObject("scripting.dictionary")
  For i = 1 To sRow
    If sArr(i, 1) <> Empty Then dic.Item(CStr(sArr(i, 1))) = i
  Next i
 
  Set cn = CreateObject("adodb.connection")
  For Each FileItem In ListFile
    cn.Open ("provider=Microsoft.ACE.OLEDB.12.0;data source=" & FileItem & ";mode=Read;extended properties=""Excel 12.0;hdr=no"";")
    Set rs = cn.Execute("select f1, f8, f9 from [$C14:K10000] where f1 is not null ")
    If Not rs.EOF() Then
      arr = rs.GetRows
      For i = LBound(arr, 2) To UBound(arr, 2)
        iR = dic.Item(arr(0, i))
        If iR > 0 Then
          For j = 1 To 12
            If res(iR, j) = Empty Then
              res(iR, j) = arr(1, i)
              res(iR, j + 12) = arr(2, i)
              exit for
            End If
          Next j
        End If
      Next i
    End If
    rs.Close:            cn.Close
  Next FileItem
  Range("I17:AF17").Resize(sRow).Value = res
  Set cn = Nothing: Set rs = Nothing
End Sub

Function GetFile(ByVal strPath As String) As Variant
  Dim sItem As Variant
  With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = True
    .InitialFileName = strPath
    .Filters.Add "Images", "*.xls*"
    If .Show = -1 Then Set GetFile = .SelectedItems Else Set GetFile = Nothing
  End With
End Function
 
Lần chỉnh sửa cuối:
Upvote 0

quyenpv

Thu nhặt kiến thức
Tham gia
5/1/13
Bài viết
546
Được thích
73
Giới tính
Nam
Nghề nghiệp
Decode cuộc đời!
Kiểm tra lại
Mã:
Option Explicit
Sub XYZ()
  Dim dic As Object, cn As Object, rs As Object, FileItem, ListFile As Object
  Dim sArr(), arr, res(), sRow&, i&, j&, iR&
 
  Set ListFile = GetFile("")
  If ListFile Is Nothing Then MsgBox "Chua chon File, thoat Sub ": Exit Sub
  sArr = Range("C17", Range("C" & Rows.Count).End(xlUp)).Value
  sRow = UBound(sArr)
  ReDim res(1 To sRow, 1 To 24)
  Set dic = CreateObject("scripting.dictionary")
  For i = 1 To sRow
    If sArr(i, 1) <> Empty Then dic.Item(CStr(sArr(i, 1))) = i
  Next i
 
  Set cn = CreateObject("adodb.connection")
  For Each FileItem In ListFile
    cn.Open ("provider=Microsoft.ACE.OLEDB.12.0;data source=" & FileItem & ";mode=Read;extended properties=""Excel 12.0;hdr=no"";")
    Set rs = cn.Execute("select f1, f8, f9 from [$C14:K] where f1 is not null ")
    If Not rs.EOF() Then
      arr = rs.GetRows
      For i = LBound(arr, 2) To UBound(arr, 2)
        iR = dic.Item(arr(0, i))
        If iR > 0 Then
          For j = 1 To 12
            If res(iR, j) = Empty Then
              res(iR, j) = arr(1, i)
              res(iR, j + 12) = arr(2, i)
            End If
          Next j
        End If
      Next i
    End If
    rs.Close:            cn.Close
  Next FileItem
  Range("I17:AF17").Resize(sRow).Value = res
  Set cn = Nothing: Set rs = Nothing
End Sub

Function GetFile(ByVal strPath As String) As Variant
  Dim sItem As Variant
  With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = True
    .InitialFileName = strPath
    .Filters.Add "Images", "*.xls*"
    If .Show = -1 Then Set GetFile = .SelectedItems Else Set GetFile = Nothing
  End With
End Function
Dạ không đúng rồi anh ạ
Code trên lấy được kết quả nhưng số lượng đang không đúng anh.
1632888053330.png
Thực tế cáp thép chỉ xuất hiện tại file BCTKTSTDV_VTU139_1632793361322.xls
1632888107391.png
 
Upvote 0

HieuCD

Chuyên gia GPE
Tham gia
14/9/10
Bài viết
8,477
Được thích
17,769
Dạ không đúng rồi anh ạ
Code trên lấy được kết quả nhưng số lượng đang không đúng anh.

Thực tế cáp thép chỉ xuất hiện tại file BCTKTSTDV_VTU139_1632793361322.xls
Chỉnh lệnh
Set rs = cn.Execute("select f1, f8, f9 from [$C14:K] where f1 is not null ")
thành
Set rs = cn.Execute("select f1, f8, f9 from [$C14:K10000] where f1 is not null ")
 
Upvote 0

quyenpv

Thu nhặt kiến thức
Tham gia
5/1/13
Bài viết
546
Được thích
73
Giới tính
Nam
Nghề nghiệp
Decode cuộc đời!
Chỉnh lệnh
Set rs = cn.Execute("select f1, f8, f9 from [$C14:K] where f1 is not null ")
thành
Set rs = cn.Execute("select f1, f8, f9 from [$C14:K10000] where f1 is not null ")
Dạ code vẫn lấy được 1 giá trị và fill đều cho 12 cột anh
Ở đây mã vật tư có thể xuất hiện nhiều lần và mỗi lần tìm kiếm trùng nó sẽ đẩy vào từ cột I nếu xuất hiện lần 2 sẽ đẩy sang cột tiếp theo ạ (em kiểm tra nhiều nhất chỉ xuất hiện 10 lần nên em đang để max là 12)
 
Upvote 0

HieuCD

Chuyên gia GPE
Tham gia
14/9/10
Bài viết
8,477
Được thích
17,769
Thêm lệnh exit for
Mã:
Sub XYZ()
  Dim dic As Object, cn As Object, rs As Object, FileItem, ListFile As Object
  Dim sArr(), arr, res(), sRow&, i&, j&, iR&
 
  Set ListFile = GetFile("")
  If ListFile Is Nothing Then MsgBox "Chua chon File, thoat Sub ": Exit Sub
  sArr = Range("C17", Range("C" & Rows.Count).End(xlUp)).Value
  sRow = UBound(sArr)
  ReDim res(1 To sRow, 1 To 24)
  Set dic = CreateObject("scripting.dictionary")
  For i = 1 To sRow
    If sArr(i, 1) <> Empty Then dic.Item(CStr(sArr(i, 1))) = i
  Next i
 
  Set cn = CreateObject("adodb.connection")
  For Each FileItem In ListFile
    cn.Open ("provider=Microsoft.ACE.OLEDB.12.0;data source=" & FileItem & ";mode=Read;extended properties=""Excel 12.0;hdr=no"";")
    Set rs = cn.Execute("select f1, f8, f9 from [$C14:K10000] where f1 is not null ")
    If Not rs.EOF() Then
      arr = rs.GetRows
      For i = LBound(arr, 2) To UBound(arr, 2)
        iR = dic.Item(arr(0, i))
        If iR > 0 Then
          For j = 1 To 12
            If res(iR, j) = Empty Then
              res(iR, j) = arr(1, i)
              res(iR, j + 12) = arr(2, i)
              Exit For
            End If
          Next j
        End If
      Next i
    End If
    rs.Close:            cn.Close
  Next FileItem
  Range("I17:AF17").Resize(sRow).Value = res
  Set cn = Nothing: Set rs = Nothing
End Sub
 
Upvote 0

quyenpv

Thu nhặt kiến thức
Tham gia
5/1/13
Bài viết
546
Được thích
73
Giới tính
Nam
Nghề nghiệp
Decode cuộc đời!
Thêm lệnh exit for
Mã:
Sub XYZ()
  Dim dic As Object, cn As Object, rs As Object, FileItem, ListFile As Object
  Dim sArr(), arr, res(), sRow&, i&, j&, iR&
 
  Set ListFile = GetFile("")
  If ListFile Is Nothing Then MsgBox "Chua chon File, thoat Sub ": Exit Sub
  sArr = Range("C17", Range("C" & Rows.Count).End(xlUp)).Value
  sRow = UBound(sArr)
  ReDim res(1 To sRow, 1 To 24)
  Set dic = CreateObject("scripting.dictionary")
  For i = 1 To sRow
    If sArr(i, 1) <> Empty Then dic.Item(CStr(sArr(i, 1))) = i
  Next i
 
  Set cn = CreateObject("adodb.connection")
  For Each FileItem In ListFile
    cn.Open ("provider=Microsoft.ACE.OLEDB.12.0;data source=" & FileItem & ";mode=Read;extended properties=""Excel 12.0;hdr=no"";")
    Set rs = cn.Execute("select f1, f8, f9 from [$C14:K10000] where f1 is not null ")
    If Not rs.EOF() Then
      arr = rs.GetRows
      For i = LBound(arr, 2) To UBound(arr, 2)
        iR = dic.Item(arr(0, i))
        If iR > 0 Then
          For j = 1 To 12
            If res(iR, j) = Empty Then
              res(iR, j) = arr(1, i)
              res(iR, j + 12) = arr(2, i)
              Exit For
            End If
          Next j
        End If
      Next i
    End If
    rs.Close:            cn.Close
  Next FileItem
  Range("I17:AF17").Resize(sRow).Value = res
  Set cn = Nothing: Set rs = Nothing
End Sub
Dạ cám ơn anh, đúng kết quả em mong muốn rồi ạ
Cám ơn anh nhiều, chúc anh sức khỏe & thành công & hạnh phúc
Cám ơn anh
Bài đã được tự động gộp:

Chỗ Mã CT mã vật tư xuất hiện cùng 2 file đều có và khác mã nhau anh, anh chỉnh thêm giúp em đưa thông tin vào cột F trong Sheet Input_TB với nhé
 
Upvote 0
Top Bottom