使用 for 复制并粘贴到其他工作表

Question

I want to copy "i" row in sheet1 and past it in sheet2(in "i" for) then find "p" row in sheet1 and insert it under of new current "i" in sheet2. this cod past all of "p" row after last "i" and I want to past it just like i describe above.

'Sub distance()
Dim j, i, s As Integer, ws, range1, range2 As Worksheet, p As Long, 
rng As Range
Set ws = Worksheets("sheet1")
For i = 2 To 9
For s = i + 1 To 18
For j = i + 1 To 9
Worksheets("sheet1").Cells(j, 11).Value = 
Sqr(((Worksheets("sheet1").Cells(i, 8).Value) 
-(Worksheets("sheet1").Cells(j, 8).Value)) ^ 2 + 
((Worksheets("sheet1").Cells(i, 
9).Value) - (Worksheets("sheet1").Cells(j, 9).Value)) ^ 2)
Next j
ws.Range("l" & i) = Application.Min(ws.Range("k3:k9"))
p = Application.Match(Application.Min(ws.Range("k3:k9")), 
ws.Range("k3:k9"), 0)
Worksheets("sheet1").Cells(i, 13).Value = p
        
Sheets("sheet1").Range("a" & i, "m" & i).Copy
Sheets("sheet2").Range("a" & i, "m" & i).PasteSpecial xlPasteValues
Sheets("sheet2").Range("a" & i + 1, "m" & i + 1).PasteSpecial 
xlPasteValues
Sheets("sheet1").Range("a" & p + 2, "l" & p + 2).Copy
Sheets("sheet2").Range("a" & s, "m" & s + 1).PasteSpecial 
xlPasteValues
Next s
'Remove the animation around the copied cell
Application.CutCopyMode = False
Next i
End Sub'

Answer 1

First calculate the distance in an extra worksheet, then copy and sort the rows. Thus, there is no need for a for loop and this speeds up the calculation.

In Sheet2 there will be every row from sheet1 and all rows which have the lowest distance to that row underneath it.

Sub calc_distance()
Set ws = Worksheets("sheet1")

'create new worksheet for calculations
If WorksheetExists("tmp") Then Sheets("tmp").Delete
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "tmp"

'copy point coordinates in columns h and i
ws.Range("H2:I90").Copy
Range("A5").PasteSpecial xlPasteValues
Range("E1").PasteSpecial xlPasteValues, Transpose:=True

'fill in formulas
Range("E5").FormulaR1C1 = _
        "=IF(OR(ROW(RC)=COLUMN(RC),R1C=""""),1E+99,SQRT((RC1-R1C)^2+(RC2-R2C)^2))"
Range("E5").AutoFill Destination:=Range("E5:Z5"), Type:=xlFillDefault
Range("E5:Z5").AutoFill Destination:=Range("E5:Z99"), Type:=xlFillDefault
Range("C5").FormulaR1C1 = "=MIN(RC[2]:RC[23])"
Range("D5").FormulaR1C1 = "=MATCH(MIN(RC[1]:RC[22]),RC[1]:RC[22],0)+0.1"
Range("C5:D5").AutoFill Destination:=Range("C5:D99"), Type:=xlFillDefault

'copy data to sheet1
Range("C5:D99").Copy
ws.Range("k2").PasteSpecial xlPasteValues

'copy rows twice to sheet2
Set target = Worksheets("sheet2")
target.Range("A1:AA9999").ClearContents
ws.Range("A1:M1").Copy
target.Range("A1").PasteSpecial xlPasteValues

ws.Range("A2:M9").Copy
target.Range("A2").PasteSpecial xlPasteValues
target.Range("A50").PasteSpecial xlPasteValues
target.Range("L2").FormulaR1C1 = "1"
target.Range("L2").AutoFill Destination:=target.Range("L2:L15"), Type:=xlFillSeries


target.Sort.SortFields.Clear
With target.Sort
    .SortFields.Add Key:=Range("L2:L99"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SetRange Range("A1:M99")
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With


End Sub

If you only want to consider points after the current row, please change the formula to

  "=IF(OR(ROW(RC)>=COLUMN(RC),R1C=""""),1E+99,SQRT((RC1-R1C)^2+(RC2-R2C)^2))"