根据预设值抓取数据同时计算长度、

lajihaha159 · 发表于 2019-12-8 16:15

新人一个，目前代码只能实现条件数据筛选，但是想要的功能更加复杂一些。详情请大佬看附件。
如觉得没说清楚请大佬留下联系方式。。

蓝桥玄霜 · 发表于 2019-12-9 11:25

数据分析的代码：

lajihaha159 · 发表于 2019-12-13 09:57

蓝桥玄霜发表于 2019-12-9 11:25
数据分析的代码：

感谢版主给代码。我测试了下好像并不出数据。。

蓝桥玄霜 · 发表于 2019-12-14 08:09

请仔细核对抄写的代码，初学者常常会抄错的。
或者上传出错的代码和附件看看。

lajihaha159 · 发表于 2019-12-16 16:57

本帖最后由 lajihaha159 于 2019-12-18 20:56 编辑

蓝桥玄霜发表于 2019-12-14 08:09
请仔细核对抄写的代码，初学者常常会抄错的。
或者上传出错的代码和附件看看。

感觉版主的回复，应该是没抄错，简单分析了代码还是没有实现，具体看附件，麻烦版主了。。

蓝桥玄霜 · 发表于 2019-12-17 08:12

没有看到你抄的代码。

lajihaha159 · 发表于 2019-12-18 13:26

本帖最后由 lajihaha159 于 2019-12-18 20:56 编辑

蓝桥玄霜发表于 2019-12-17 08:12
没有看到你抄的代码。

代码已经加进去了。。前面的附件代码没有保存好，看版主再看看。。

蓝桥玄霜 · 发表于 2019-12-19 08:36

还是有2个地方抄错了：

Dim Arr
Sub lqxs()
Dim i&, ks&, mx, n%, zh, m%, aa, j%
Dim d, k, t, nn&, jj%
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False '这一句
Sheet2.Activate
[a11:Z5000].ClearContents: nn = 10
Arr = Sheet1.[a1].CurrentRegion
For i = 3 To UBound(Arr)
If Arr(i - 1, 5) < 3 Then
If Arr(i, 5) >= 3 Then
ks = i: n = n + 1
d(Arr(i, 5)) = d(Arr(i, 5)) & i & ","
End If
Else
If Arr(i, 5) >= 3 Then
d(Arr(i, 5)) = d(Arr(i, 5)) & i & ","
n = n + 1
Else
k = d.keys: t = d.items
mx = Application.Max(k) '这一句
If mx > 6 Then
zh = n * 0.25
m = Application.Match(mx, k, 0) - 1
t(m) = Left(t(m), Len(t(m)) - 1)
If InStr(t(m), ",") Then
aa = Split(t(m), ",")
For jj = 0 To UBound(aa)
nn = nn + 1
Call tb(nn, mx, zh, aa(jj))
Next
Else
nn = nn + 1
Call tb(nn, mx, zh, t(m))
End If
End If
d.RemoveAll
n = 0
End If
End If
Next
Application.ScreenUpdating = True
End Sub

复制代码

lsdongjh · 发表于 2019-12-19 12:59

Option Explicit
Sub Main()
Dim shData As Worksheet, shCondition As Worksheet, shResult As Worksheet
Dim arrData As Variant, arrCondition As Variant, objColID As Object
Dim lngRow As Long, lngCol As Long, lngRow2 As Long
Dim lngColID As Long, lngCurRow As Long
Dim arrJudgeCondition As Variant, strName As String, strCountChar As String, strCountVal As String, strMaxChar As String, strMaxVal As String
Dim arrResult As Variant, strTemp As String, lngCount As Long, dblMaxOrMin As Double, strRowID As String, blHasOK As Boolean
Dim strSplit() As String, lngID As Long, arrTemp As Variant
Set shData = Sheets("数据")
Set shCondition = Sheets("分析条件")
Set shResult = Sheets("分析结果")
Set objColID = GetDicByColID
arrData = shData.UsedRange '源数据
arrCondition = shCondition.Range("A10:J18") '条件数据
ReDim arrResult(1 To UBound(arrData), 1 To 26)
For lngCol = 2 To UBound(arrCondition, 2)
strName = arrCondition(1, lngCol)
For lngRow = 2 To UBound(arrCondition) Step 4
strCountChar = arrCondition(lngRow, lngCol)
strCountVal = arrCondition(lngRow + 1, lngCol)
strMaxChar = arrCondition(lngRow + 2, lngCol)
strMaxVal = arrCondition(lngRow + 3, lngCol)
'格式化条件
arrJudgeCondition = GetJudgeCondition(strName, strCountChar, strCountVal, strMaxChar, strMaxVal)
'如果条件列存在
If objColID.Exists(arrJudgeCondition(0)) Then
lngColID = objColID(arrJudgeCondition(0))
'
For lngRow2 = 2 To UBound(arrData)
strTemp = arrData(lngRow2, lngColID)
If Trim(strTemp) <> "" Then
'符合条件开始计数
If Application.Evaluate(strTemp & arrJudgeCondition(1)) = True Then
blHasOK = True
lngCount = lngCount + 1
'峰值条件判断
If Application.Evaluate(strTemp & arrJudgeCondition(2)) = True Then
If Val(strTemp) > dblMaxOrMin Then
dblMaxOrMin = Val(strTemp)
strRowID = lngRow2
ElseIf Val(strTemp) = dblMaxOrMin Then
strRowID = strRowID & "|" & lngRow2
End If
End If
Else
If blHasOK And strRowID <> "" Then
strSplit = Split(strRowID, "|")
For lngID = LBound(strSplit) To UBound(strSplit)
lngCurRow = lngCurRow + 1
arrTemp = Application.WorksheetFunction.Index(arrData, Val(strSplit(lngID)), 0)
PutDataToResult arrTemp, lngCurRow, lngCount * 0.25, lngColID, arrResult
Next
End If
blHasOK = False
lngCount = 0
dblMaxOrMin = -99999
strRowID = ""
End If
End If
Next
End If
Next
Next
lngRow = shResult.UsedRange.Rows.Count
If lngRow < 11 Then lngRow = 11
shResult.Range("A11:Z" & lngRow).Clear
shResult.Range("A11").Resize(lngCurRow, 26) = arrResult
Set shData = Nothing
Set shCondition = Nothing
Set shResult = Nothing
Set objColID = Nothing
MsgBox "OK"
End Sub
Function PutDataToResult(arrData As Variant, lngRowID As Long, dblLength As Double, lngColID As Long, ByRef arrResult As Variant)
Dim lngRow As Long
For lngRow = 1 To 5
arrResult(lngRowID, lngRow) = arrData(lngRow)
Next
For lngRow = 6 To 12
arrResult(lngRowID, lngRow * 2 - 5) = arrData(lngRow)
Next
For lngRow = 13 To 16
arrResult(lngRowID, lngRow + 7) = arrData(lngRow)
Next
arrResult(lngRowID, 25) = arrData(17)
Select Case lngColID
Case 17
arrResult(lngRowID, 26) = dblLength
Case 16
arrResult(lngRowID, 24) = dblLength
Case 6 To 11
arrResult(lngRowID, lngColID * 2 - 4) = dblLength
Case 5
arrResult(lngRowID, 6) = dblLength
End Select
End Function
Function GetDicByColID() As Object
Dim objDic As Object, shData As Worksheet, arrData As Variant
Dim strKey As String, lngCol As Long
Set shData = Sheets("数据")
arrData = shData.Range("A1:Q1")
Set objDic = CreateObject("Scripting.Dictionary")
For lngCol = 1 To UBound(arrData, 2)
strKey = Trim(arrData(1, lngCol))
objDic(strKey) = lngCol
Next
Set shData = Nothing
Set GetDicByColID = objDic
End Function
Function GetJudgeCondition(strName As String, strCountChar As String, strCountVal As String, strMaxChar As String, strMaxVal As String) As Variant
Dim strResult(2) As String, strTemp As String
strResult(0) = Trim(strName)
strResult(1) = myReplace(strCountChar, strCountVal)
strResult(2) = myReplace(strMaxChar, strMaxVal)
GetJudgeCondition = strResult
End Function
Function myReplace(strOld As String, strVal As String) As String
Dim strReturn As String
strReturn = strOld & Val(strVal)
strReturn = Replace(strReturn, Space(1), "")
strReturn = Replace(strReturn, "大于", ">")
strReturn = Replace(strReturn, "小于", "<")
strReturn = Replace(strReturn, "等于", "=")
myReplace = strReturn
End Function

复制代码

lsdongjh · 发表于 2019-12-19 13:00

代码审核中，见附件

想实现的目的.rar (32.32 KB, 下载次数: 3)

		自动登录	找回密码
密码			免费注册

[求助] 根据预设值抓取数据同时计算长度、

评分

最新热点 /1