Question

编辑：我已经解决了本文中解决的问题。感谢所有提供帮助的人。基本的解决方案是将我的代码放到错误的模块中。

我有一些Excel图表的X＆Y数据，需要在图中找到拐角的位置。

使用宏，我开始评估数据，但是还没有找到合理的方法来发现坡度的明显变化以识别拐角。

我有一列具有X值，另一列具有Y值。

如果您查看拐角处的圆，我正在寻找该拐角的位置。它不一定要非常准确，但是要尽可能地好。

我在其他答案中找到了一些这样的代码，但是其中大部分是从宏记录器中修改的。我仍在尝试使其获得一阶和二阶导数。这就是前两个大代码块试图完成的工作。我希望使用局部最大值或类似的东西来确定拐角位置。

Option Explicit
Option Compare Text
Sub FindSlopeIncrease()
Dim lastrow As Long
Dim chtObj As ChartObject
Dim Slope As Double
Dim rng As Range
Dim Start As Integer
Dim Load As Integer
Dim DDate As String
Dim f As Variant
Dim src As Object
Dim myfile As Variant
Dim i As Integer
Dim mysheet As Variant
Dim x As Integer
Dim savefile As Workbook

Let Slope = 0
Let Start = 400 'cell value to start searching from

DDate = Date

Call Lights_Off 'Turns off screenupdating and warning messages to increase speed of macro

myfile = Application.GetOpenFilename(MultiSelect:=True) 'Returns filename as string to open .xls spreadsheets.
    If TypeName(myfile) = "False" Then
        Exit Sub
    End If

    Set savefile = Workbooks.Add
    ActiveWorkbook.Activate
    ActiveSheet.Range("A1") = "Load (N)"

    If IsArray(myfile) Then
        For i = LBound(myfile) To UBound(myfile)
        'Runs array to open multiple files at a time

            Set src = Workbooks.Open(myfile(i), ReadOnly:=True)

            Worksheets(1).Activate

            For Each chtObj In ActiveSheet.ChartObjects
                chtObj.Delete
            Next

            lastrow = ActiveSheet.UsedRange.Rows.Count + 1

            ActiveSheet.Columns(6).ClearContents
            ActiveSheet.Columns(7).ClearContents
            ActiveSheet.Columns(8).ClearContents
            ActiveSheet.Columns(9).ClearContents

            ActiveSheet.Range("C8:C" & lastrow).Copy
            ActiveSheet.Range("F8:F" & lastrow).PasteSpecial
            ActiveSheet.Range("C8").Copy
            ActiveSheet.Range("F8:F" & lastrow).PasteSpecial Operation:=xlPasteSpecialOperationSubtract
            ActiveSheet.Range("F6") = "Extension(mm)"

            For x = Start To lastrow
                Set rng = Range("A" & x, "A" & x + 2)
                If x = Start Then
                    Slope = WorksheetFunction.Slope(rng, rng.Offset(0, 1))
                    GoTo 1
                ElseIf WorksheetFunction.Slope(rng, rng.Offset(0, 1)) - 400 >= Slope Then
                    MsgBox "Slope = " & Slope & " Cell value = " & x
                    Let Load = Range("A" & x)
                    MsgBox "Can Contact load = " & Load & "N"
                    savefile.Activate
                    ActiveWorkbook.ActiveSheet.Range("A" & i + 1) = [Load]
                    GoTo 2
                End If

1:          Slope = WorksheetFunction.Slope(rng, rng.Offset(0, 1))
            Next x
2:
            src.Close False
            'Closes Spreadsheet after data has been saved
            Set src = Nothing
            Next i 'Goes to next "i": runs the next file in line for multiple file selections
                Else
            End If
ErrHandler:
            Application.EnableEvents = True
            Application.ScreenUpdating = True


ActiveWorkbook.SaveAs Filename:=Month(DDate) & Day(DDate) & Year(DDate) & " Can Contact Load Summary", FileFormat:=xlWorkbookNormal, CreateBackup:=False

    ActiveWorkbook.Close

    Call Lights_On 'Turns screenupdating and Warning messages back on
End Sub

Public Sub Lights_Off()

    '\\ Turns OFF screen updating and warning messages to speed up macro.

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False

End Sub
Public Sub Lights_On()

    '\\ Turns ON screen updating and warning messages when macro stops.

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True

End Sub

使用Excel宏查找坡度变化点

0 个答案: