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

quyenpv · 28/9/21

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

Trong file xuất ra từ phần mềm

quyenpv · 28/9/21

Các anh chị xem giúp em với nhé. Cám ơn

HieuCD · 29/9/21

quyenpv đã viết:
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

quyenpv · 29/9/21

HieuCD đã viết:

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.

Thực tế cáp thép chỉ xuất hiện tại file BCTKTSTDV_VTU139_1632793361322.xls

HieuCD · 29/9/21

quyenpv đã viết:
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 ")

quyenpv · 29/9/21

HieuCD đã viết:
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 ")

quyenpv đã viết:
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)

HieuCD · 29/9/21

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

quyenpv · 29/9/21

HieuCD đã viết:

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: 29/9/21

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é

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

quyenpv

Thu nhặt kiến thức

File đính kèm

quyenpv

Thu nhặt kiến thức

HieuCD

Chuyên gia GPE

quyenpv

Thu nhặt kiến thức

HieuCD

Chuyên gia GPE

quyenpv

Thu nhặt kiến thức

HieuCD

Chuyên gia GPE

quyenpv

Thu nhặt kiến thức

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