筛选非空的单元格，然后输出为单独的EXCEL文件，感谢大神

prc3

需求1：
请问各位大神，条件是B列不为空，筛选后将结果输出到一个单独的EXCEL


需求2：
还是B列不为空，如果是根据A列的分公司名字作为条件，不同的分公司生成一个不同的工作表，分公司名字就是工作表名字，那么又该怎么写，如果麻烦的话这个需求就算了，帮忙看看需求1就可以了

筛选求助.rar (29.65 KB, 下载次数: 38)

2017-2-20 15:01 上传

点击文件名下载附件

prc3

如果实在麻烦的话，大神帮忙看看第一个需求就可以了，谢谢大家

prc3

麻烦各位了，就帮忙处理下需求一就可以了

高手都不在啊

jiangdifeng

菜鸟第一次来回答下。思路是判断id号是否为空值，然后建立新的工作薄，然后判断是否存在对应的工作表，没有的新建一个，有的话直接activate，然后写入数值。其中查找是否存在工作表的步骤比较傻。先凑活下。 我自己这里运行啦，可以用。你拿去试一试看。

Sub xuqiu1()

    Dim cellrange As Range

    Dim singlecell As Range

    Dim company As String

    Dim i As Integer

    Dim k As Integer

    Dim total As Integer

    total = 0

    ThisWorkbook.Activate

    Worksheets("sheet1").Activate

    Set cellrange = Range("b2", Range("b4000").End(xlUp))

    Workbooks.Add

    For Each singlecell In cellrange

        If singlecell.Value <> "" Then

        company = singlecell.Offset(0, -1).Value

        For i = 1 To Worksheets.Count

            If Worksheets(i).Name <> company Then

                k = 0

                total = k + total

            Else

                k = 1

                total = k + total

            End If

        Next i

        If total <> 0 Then

            Debug.Print company

            Worksheets(company).Activate

        Else

            Worksheets.Add

            ActiveSheet.Name = company

            Range("a1").Value = "company"

            Range("b1").Value = "number"

            Range("c1").Value = "time"

            Range("a2").Select

        End If

        total = 0

        ActiveCell.Value = singlecell.Offset(0, -1).Value

        ActiveCell.Offset(0, 1).Value = singlecell.Value

        ActiveCell.Offset(0, 2).Value = singlecell.Offset(0, 1).Value

        ActiveCell.Offset(1, 0).Select

        End If

    Next singlecell

End Sub

prc3

代码不全吧？另外这行直接报错：  Set cellrange = Range("b2", Range("b<span style="color: rgb(102, 102, 102); font-family: Monaco, Consolas, &quot;Lucida Console&quot;, &quot;Courier New&quot;, serif; font-size: 12px;">65536</span>").End(xlUp))   


实在不行有需求1就可以了

lsc900707

Sub lsc()
     Dim arr, d As Object, k, t, i&, lc%, rng As Range, c%
     c = Application.InputBox("请输入拆分列号", , 4, , , , , 1)
     If c = 0 Then Exit Sub
     Application.ScreenUpdating = False
     Application.DisplayAlerts = False
     arr = [a1].CurrentRegion
     lc = UBound(arr, 2)
     Set rng = [a1].Resize(, lc)
     Set d = CreateObject("scripting.dictionary")
     For i = 2 To UBound(arr)
         If arr(i, 2) <> "" Then
             If Not d.Exists(arr(i, c)) Then
                  Set d(arr(i, c)) = Cells(i, 1).Resize(1, lc)
             Else
                  Set d(arr(i, c)) = Union(d(arr(i, c)), Cells(i, 1).Resize(1, lc))
             End If
         End If
     Next
     k = d.Keys
     t = d.Items
     For i = 0 To d.Count - 1
         With Workbooks.Add(xlWBATWorksheet)
             rng.Copy .Sheets(1).[a1]
             t(i).Copy .Sheets(1).[a2]
             .SaveAs Filename:=ThisWorkbook.Path & "\" & k(i)
             .Close
         End With
     Next
     Application.DisplayAlerts = True
     Application.ScreenUpdating = True
     MsgBox "完毕"
End Sub

prc3

lsc900707 发表于 2017-2-20 18:10
Sub lsc()
     Dim arr, d As Object, k, t, i&, lc%, rng As Range, c%
     c = Application.InputBox ...

老大，非常不错，解决了问题，万分感谢。 不过我是想把生成的结果保存为一个工作薄的不同工作表，而不是保存为N个工作薄，应该怎么修改呢 ？麻烦你了

lsc900707

prc3 发表于 2017-2-21 17:28
老大，非常不错，解决了问题，万分感谢。 不过我是想把生成的结果保存为一个工作薄的不同工作表，而不是 ...

那更简单了，晚一点给代码吧。

lsc900707

prc3 发表于 2017-2-21 17:28
老大，非常不错，解决了问题，万分感谢。 不过我是想把生成的结果保存为一个工作薄的不同工作表，而不是 ...

试试这个吧，代码放sheet1工作表代码区，按钮用控件按钮运行：
Private Sub CommandButton1_Click()
    Dim tim1 As Date, tim2 As Date: tim1 = Timer
    Dim arr, d As Object, sh As Worksheet
    Set d = CreateObject("scripting.dictionary")
    arr = Range("a1").CurrentRegion
    For i = 2 To UBound(arr)
        If arr(i, 2) <> "" Then
            If Not d.exists(arr(i, 1)) Then
                Set d(arr(i, 1)) = Range("a" & i).Resize(1, 3)
            Else
                Set d(arr(i, 1)) = Union(d(arr(i, 1)), Range("a" & i).Resize(1, 3))
            End If
        End If
    Next
    x = d.keys
    For k = 1 To UBound(x)
        Set sh = ActiveWorkbook.Sheets.Add(, after:=ActiveSheet)
        sh.Name = x(k)
        d.items()(k).Copy sh.Range("a" & 2)
        Rows("1:1").Copy sh.Range("a1")
        sh.Cells.EntireColumn.AutoFit
    Next
    lsc
    tim2 = Timer
    MsgBox Format(tim2 - tim1, "拆分完成，共耗时：0.00秒"), 64, "时间统计"
End Sub

Sub lsc()
    Dim sh As Worksheet, m&
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each sh In Worksheets
        If sh.Name <> "Sheet1" Then
            m = m + 1
            If m = 1 Then sh.Select Else sh.Select False
        End If
    Next
    ActiveWindow.SelectedSheets.Copy
    ActiveWorkbook.Close True, ThisWorkbook.Path & "\拆分后的表"
    Sheets("Sheet1").Select
    Application.ScreenUpdating = True
    MsgBox "保存完毕"
End Sub

百旺表格

蓝桥大师 水平高。

我是新手，有个类似的 表。也需要帮忙。可是，新手权限不够啊。这里多攒积分吧