[已解决]求助如何不要提取没值的公式作为人次，而提取有值的出现次数作为人次

qinhuan66

求助如何不要提取没值的公式作为人次，而提取有值的出现次数作为人次 测试.rar (58.64 KB, 下载次数: 2)

2013-2-5 22:09 上传

点击文件名下载附件





Do While wj <> ""
    If s = 2 Then
        ReDim arr(1 To 21, 1 To 1)
    Else
        ReDim Preserve arr(1 To 21, 1 To UBound(arr, 2) + 1)
    End If
    s = s + 1
    Set fs = GetObject(ThisWorkbook.Path & "\数据库\" & wj)
    arr(1, s - 2) = s - 2
    arr(2, s - 2) = Mid(wj, 4, IIf(InStr(wj, "区") > 0, InStr(wj, "区") - 3, InStr(wj, "村") - 3))
    arr(3, s - 2) = "=SUM(RC[1]+RC[2])"
    arr(6, s - 2) = "=SUM(RC[1]+RC[4]+RC[5])"
    arr(7, s - 2) = "=SUM(RC[1]+RC[2])"
    arr(8, s - 2) = "=SUM(55*(RC[-5]-RC[7]))"
    arr(9, s - 2) = "=SUM(25*(RC[-6]-RC[6]))"
    arr(10, s - 2) = Application.WorksheetFunction.Sum(fs.Sheets(1).Range("I6:I1000"))
    arr(11, s - 2) = "=SUM(RC[1]+RC[2])"
    arr(12, s - 2) = "=SUM(55*RC[5])"
    arr(13, s - 2) = "=SUM(25*RC[4])"
    arr(14, s - 2) = Application.WorksheetFunction.Sum(fs.Sheets(1).Range("L6:L1000"))
    arr(15, s - 2) = Application.WorksheetFunction.CountIf(fs.Sheets(1).Range("Q6:Q1000"), "死亡停发")
    arr(16, s - 2) = "死亡"
    arr(17, s - 2) = Application.WorksheetFunction.CountA(fs.Sheets(1).Range("J6:J1000"))
    arr(19, s - 2) = ""
    arr(20, s - 2) = ""
    arr(21, s - 2) = ""
    With fs.Sheets(1)
        N1 = 0
        N2 = 0
        For Each Rng In .Range("d6:d" & .Cells(.Rows.Count, 4).End(3).Row)
            If Rng <> "" And (.Cells(Rng.Row, "Q").Value = "正常发放" Or .Cells(Rng.Row, "Q").Value = "死亡停发") Then
                Y = Val(IIf(Len(Rng.Text) = 18, Mid(Trim(Rng.Text), 7, 4), "19" & Mid(Trim(Rng.Text), 7, 2)))
                Select Case Y
                    Case Is <= 1949
                        N1 = N1 + 1
                    Case Is <= 1952
                        N2 = N2 + 1
                    Case Else

                End Select
            End If
        Next Rng
    End With
    arr(4, s - 2) = Val(arr(4, s - 2)) + N1
    arr(5, s - 2) = Val(arr(5, s - 2)) + N2
    fs.Close False
    wj = Dir
Loop
Cells(7, 1).Resize(UBound(arr, 2), UBound(arr)) = Application.Transpose(arr)
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

最佳答案

月排行榜 / 总排行榜

cbg2008

2013-2-5 22:19

arr(17, s - 2) = Application.WorksheetFunction.Count(fs.Sheets(1).Range("J6:J1000"))
COUNTA 改成COUNT

跳转到最佳答案楼层

cbg2008

arr(17, s - 2) = Application.WorksheetFunction.Count(fs.Sheets(1).Range("J6:J1000"))
COUNTA 改成COUNT

qinhuan66

cbg2008 发表于 2013-2-5 22:19
arr(17, s - 2) = Application.WorksheetFunction.Count(fs.Sheets(1).Range("J6:J1000"))
COUNTA 改成COU ...

谢谢了兄弟 真的非常感谢您

qinhuan66

cbg2008 发表于 2013-2-5 22:19
arr(17, s - 2) = Application.WorksheetFunction.Count(fs.Sheets(1).Range("J6:J1000"))
COUNTA 改成COU ...

求助cbg2008 老师
如何修改红框圈内黄底色的这句代码提取数据库文件夹的资料换成提取数据库文件夹内子文件夹的所有资料  谢谢

测试.rar (115.82 KB, 下载次数: 0)

2013-2-6 10:53 上传

点击文件名下载附件


  

Sub 提取数据()
   Dim myPath$, myFile$, AK As Workbook, aRow%, tRow%
   Application.ScreenUpdating = False        '冻结屏幕，以防屏幕抖动
   Application.DisplayAlerts = False
   
   myPath = ThisWorkbook.Path & "\数据库\"          '把文件路径定义给变量
   
   myFile = Dir(myPath & "*.xls")            '依次找寻指定路径中的*.xls文件
   Do While myFile <> ""                     '当指定路径中有文件时进行循环
      If myFile <> ThisWorkbook.Name Then
         Set AK = Workbooks.Open(myPath & myFile)          '打开符合要求的文件
         
         For i = 6 To 65536 Step 1
         If AK.Sheets(1).Cells(i, 1).Value <> "" Then
         
         Else
         Exit For
         End If
         Next
         
         aRow = i - 1
         tRow = ThisWorkbook.Sheets(1).Range("A65536").End(xlUp).Row + 1
         If tRow < 5 Then tRow = 5
         
         
         arr = AK.Sheets(1).Range("a6:q" & aRow)
         ThisWorkbook.Sheets(1).Range("A" & tRow).Resize(UBound(arr), UBound(arr, 2)) = arr
         ThisWorkbook.Sheets(1).Range("R" & tRow).Resize(UBound(arr), 1) = AK.Sheets(1).Range("c2")
         
         Workbooks(myFile).Close False               '关闭源工作簿,并不作修改
      End If
      myFile = Dir                                   '找寻下一个*.xls文件
   Loop
      
   Application.ScreenUpdating = True                 '冻结屏幕,此类语句一般成对使用
   MsgBox "汇总完成，请查看！", 64, "提示"
End Sub

cbg2008

给你一个类似的代码参考
Sub App_FileSearch()
'Stop
Const keyword As String = "*.xl*"
    Call App_SearchSubFolder(keyword, True)
    If UBound(strArr) > 0 Then
        ActiveSheet.Range("a2:a65536").Clear
        x = 0
        For i = 0 To UBound(strArr)
            If strArr(i) <> "" And strArr(i) Like "[SF]*" Then
                x = x + 1
                ActiveSheet.Hyperlinks.Add Anchor:=Cells(x + 2, "A"), _
                        Address:=strArr(i), TextToDisplay:=strArr(i)
            End If
        Next i
    Else
        MsgBox "没有发现文件"
    End If
   
End Sub

Function App_SearchSubFolder(keyword As String, rSearchSubFolders As Boolean)
Dim fd As Object
Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
'    If fd.Show = -1 Then
        rLookIn = ThisWorkbook.Path    'fd.SelectedItems(1)
'    Else
'        MsgBox "未选取文件夹": Exit Function
'    End If
    rFilename = Dir$(rLookIn & "\" & keyword)
'    If rFilename = ThisWorkbook.Name Then Exit Function
    rCount = 0
    ReDim Preserve strArr(rCount)
    Do While rFilename <> vbNullString
        If rFilename <> ThisWorkbook.Name Then
            strArr(rCount) = rFilename
            rCount = rCount + 1
            ReDim Preserve strArr(rCount)
        End If
        rFilename = Dir$()
    Loop
    If rSearchSubFolders Then
        Call App_NextSubFolder(fso.GetFolder(rLookIn), keyword)
    End If
'    Set fd = Nothing
'    Set fso = Nothing
End Function

Private Sub App_NextSubFolder(ByRef Folder As Object, ByRef keyword As String)
Dim SubFolder As Object
    For Each SubFolder In Folder.SubFolders
        rFilename = Dir$(SubFolder.Path & "\" & keyword)
        Do While rFilename <> vbNullString
            strArr(rCount) = SubFolder.Path & "\" & rFilename
            rCount = rCount + 1
            ReDim Preserve strArr(rCount)
            rFilename = Dir$()
        Loop
        Call App_NextSubFolder(SubFolder, keyword)
    Next
End Sub

qinhuan66

cbg2008 发表于 2013-2-6 13:12
给你一个类似的代码参考
Sub App_FileSearch()
'Stop

谢谢我琢磨一下