将分支电缆导入到电缆标牌表中

yynrzwh

Sub test()

ar = Sheet5.Range("a1").CurrentRegion
With Sheet4
    .UsedRange.Offset(, 2).Clear
    .UsedRange.Offset(5).Clear
    Set Rng = .Range("a2:b5")
    r = 2: c = 1
    For i = 3 To UBound(ar)
        Rng.Copy .Cells(r, c)
        .Cells(r, c + 1).Resize(4) = ""
        .Cells(r, c + 1) = ar(i, 2)
        .Cells(r + 1, c + 1) = ar(i, 3)
        .Cells(r + 2, c + 1) = ar(i, 4)
        .Cells(r + 3, c + 1) = ar(i, 5)
        c = c + 3
        If c > 10 Then
            c = 1
            r = r + 5
        End If
    Next
End With
End Sub

天涯887

跟我那个问题好像哦

wang-way

天涯887 发表于 2024-9-10 10:26
跟我那个问题好像哦

这种问题 隔几天就有

◆华佗◆

鄂龙蒙 发表于 2024-9-9 15:20

能否帮忙生成一式二份？

ykcbf1100

练手。。。

增加一个模板表，这样线框不用临时去画。

ykcbf1100

。。。。。。。。。。。。。。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.9.17
   
2.     Application.ScreenUpdating = False
   
3.     With Sheets("分支电缆")
   
4.         r = .Cells(Rows.Count, 1).End(3).Row
   
5.         arr = .[b1].Resize(r, 4)
   
6.     End With
   
7.     Set Rng = Sheets("模板").Rows("1:5")
   
8.     ReDim brr(1 To r, 1 To 4)
   
9.     For i = 3 To UBound(arr)
   
10.         If arr(i, 1) <> Empty Then
    
11.             n = n + 1
    
12.             For j = 1 To UBound(arr, 2)
    
13.                 brr(n, j) = arr(i, j)
    
14.             Next
    
15.         End If
    
16.     Next
    
17.     m = 1
    
18.     On Error Resume Next
    
19.     With Sheets("电缆标牌")
    
20.         .Cells.Clear
    
21.         For i = 1 To n Step 4
    
22.             Rng.Copy .Cells(m, 1)
    
23.             For x = 1 To 4
    
24.                 For j = 1 To UBound(brr, 2)
    
25.                     .Cells(m + j, 2 + (x - 1) * 3) = brr(i, j)
    
26.                 Next
    
27.             Next
    
28.             m = m + 5
    
29.         Next
    
30.     End With
    
31.     Set Rng = Nothing
    
32.     Application.ScreenUpdating = True
    
33.     MsgBox "OK！"
    
34. End Sub
    
35. 
    

复制代码

Qs18

1. Sub qs()
   
2. Application.ScreenUpdating = False
   
3. With Sheet5
   
4. Sheet4.Range("a2:b5").Copy Sheet4.Range("r2")
   
5. ReDim a(1 To 4, 1 To 1)
   
6. cc = 1: rr = 2
   
7. r = .UsedRange.Rows.Count
   
8. arr = .Range("b3:e" & r).Value
   
9. For i = 1 To UBound(arr)
   
10.     If arr(i, 1) <> Empty Then
    
11.         For c = 1 To 4
    
12.             a(c, 1) = arr(i, c)
    
13.         Next
    
14.     End If
    
15.     With Sheet4
    
16.     If cc > 10 Then cc = 1: rr = rr + 5
    
17.     .Range("s2").Resize(4, 1) = a
    
18.     .Range("r2:s5").Copy .Cells(rr, cc)
    
19.     cc = cc + 3
    
20.     End With
    
21. Next
    
22. End With
    
23. Sheet4.Range("r2:s5").Clear
    
24. Application.ScreenUpdating = True
    
25. End Sub
    

复制代码

Qs18

试试。。。。。。。。

Qs18

试试。。。。。。。