按调出店铺名自动拆分总表中相关的数据

fanweibbt · 发表于 2019-10-19 10:37

按调出店铺名自动拆分总表中相关的数据到分表中

fanweibbt · 发表于 2019-10-19 11:34

在以往的贴子中找到答案了

一把小刀闯天下 · 发表于 2019-10-19 12:00

Option Explicit

Sub test()
  Dim arr, sht, i, j, m
  Call doevent(False)
  For Each sht In Sheets
If sht.Name <> "Sheet1" Then sht.Delete
  Next
  arr = Sheets("sheet1").[a1].CurrentRegion.Offset(1).Resize(, 7)
  Call bsort(arr, 1, UBound(arr, 1) - 1, 1, UBound(arr, 2), 4)
  For i = 1 To UBound(arr, 1) - 1
m = m + 1
For j = 1 To UBound(arr, 2)
   arr(m, j) = arr(i, j)
Next
If arr(i, 4) <> arr(i + 1, 4) Then
   Sheets.Add
   With ActiveSheet
      .Name = arr(i, 4)
      .[a2].Resize(m, UBound(arr, 2)) = arr
      Sheets("sheet1").[a1].Resize(1, UBound(arr, 2)).Copy [a1]
      .[a1].Resize(m + 1, UBound(arr, 2)).Borders.LineStyle = xlContinuous
   End With
   m = 0
End If
  Next
  Call doevent(True)
End Sub

Function bsort(arr, first, last, left, right, key)
  Dim i, j, k, t
  For i = first To last - 1
For j = first To last + first - 1 - i
   If StrComp(arr(j, key), arr(j + 1, key), vbTextCompare) = 1 Then
      For k = left To right
      t = arr(j, k): arr(j, k) = arr(j + 1, k): arr(j + 1, k) = t
      Next
   End If
  Next j, i
End Function

Function doevent(flag As Boolean)
  With Application
.DisplayAlerts = flag
.ScreenUpdating = flag
  End With
End Function

用心修炼 · 发表于 2019-10-19 13:23

本帖最后由用心修炼于 2019-10-19 13:26 编辑

请查收附件！
添加了一个窗体，把调出店铺都放在了listbox中，同时可以在本文框中输入关键字老模糊搜索店铺名，结果会显示在；列表框中，然后在列表框中点击要显示的调出店铺名，再单击“确定”按钮，即可复制数据到指定表格中。增加了一点小容错率，假如工作薄中没有“调出店铺”的表名，会有提示