批量减列数据的问题

杨小妹

附件 批量减列数据.rar (561.33 KB, 下载次数: 8)

2024-12-22 19:44 上传

点击文件名下载附件

谢谢老师！

sj15627581616

盲猜

sj15627581616

1. Sub test()
   
2.     Dim arr, brr()
   
3.     Dim i As Long, n As Integer
   
4.     arr = Sheets("Sheet1").UsedRange
   
5.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2) * 2 - 2)
   
6.     For i = 1 To UBound(arr)
   
7.         If arr(i, 1) Then '跳过空值行
   
8.             n = 3
   
9.             brr(i, 1) = arr(i, 1)
   
10.             For c = 3 To UBound(arr, 2)
    
11.                 brr(i, n) = arr(i, c)
    
12.                 n = n + 1
    
13.                 brr(i, n) = arr(i, 1) - arr(i, c)
    
14.                 n = n + 1
    
15.             Next
    
16.         End If
    
17.     Next
    
18.     Sheets("Sheet3").Range("A1").Resize(UBound(arr), UBound(brr, 2)) = brr
    
19. End Sub
    

复制代码

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.12.22
   
2.     Application.ScreenUpdating = False
   
3.     With Sheets("Sheet1")
   
4.         r = .Cells(Rows.Count, 1).End(3).Row
   
5.         c = .UsedRange.Columns.Count
   
6.         arr = .[a1].Resize(r, c)
   
7.     End With
   
8.     ReDim brr(1 To UBound(arr), 1 To 1000)
   
9.     For i = 1 To UBound(arr)
   
10.         m = m + 1
    
11.         brr(m, 1) = arr(i, 1)
    
12.         For j = 3 To UBound(arr, 2)
    
13.             n = 2 * j - 2
    
14.             brr(m, n - 1) = arr(i, j)
    
15.             brr(m, n) = brr(m, 1) - arr(i, j)
    
16.         Next
    
17.     Next
    
18.     With Sheets("Sheet2")
    
19.         .UsedRange.ClearContents
    
20.         .[a1].Resize(m, n) = brr
    
21.     End With
    
22.     Application.ScreenUpdating = True
    
23.     MsgBox "OK！"
    
24. End Sub
    

复制代码

quqiyuan

参与一下，仅供参考。。。

quqiyuan

代码如下。。。。
Sub test()
    Dim wb As Workbook, sht As Worksheet
    Application.ScreenUpdating = False
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("sheet1")
    r = sht.Cells(Rows.Count, 1).End(3).Row
    c = sht.Cells(1, Columns.Count).End(1).Column
    For i = c To 4 Step -1
        sht.Columns(i).Insert
    Next
    c = sht.Cells(1, Columns.Count).End(1).Column
    arr = sht.Range([a1], Cells(r, c))
    For j = 3 To c Step 2
        ReDim brr(1 To r, 0)
        For i = 1 To r
            If arr(i, 1) <> Empty Then
                brr(i, 0) = arr(i, 1) - arr(i, j)
            End If
        Next
        sht.Cells(1, j + 1).Resize(r) = brr
    Next
    Application.ScreenUpdating = True
    Beep
End Sub