如何将教师按学科横排变成竖排

sxdmsz

如何将教师按学科横排变成竖排，具体见表格右边OP两列格式，谢谢 2.rar (7.32 KB, 下载次数: 27)

2024-8-8 08:48 上传

点击文件名下载附件

limonet

关键字：redim preserve

limonet

Sub limonet()
    Dim Arr As Variant, i%, j%, k%, L%, Brr() As Variant
    Arr = Range("A2:K17")
    For i = 1 To UBound(Arr) Step 2
        For k = 0 To 1
            For j = 3 To UBound(Arr, 2)
                If Arr(i + k, j) <> "" Then
                    L = L + 1
                    ReDim Preserve Brr(1 To 2, 1 To L)
                    Brr(1, L) = Arr(i + k, j): Brr(2, L) = Arr(i, 1)
                End If
            Next j
        Next k
    Next i
    Range("P2").Resize(L, 2) = Application.Transpose(Brr)
End Sub

limonet

Arr = Range("A2:K" & Range("L" & Rows.Count).End(xlUp).Row + 1)

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.8.8
   
2.     r = ActiveSheet.UsedRange.Find("教师总数").Row
   
3.     arr = [a1].Resize(r - 1, 11)
   
4.     ReDim brr(1 To 1000, 1 To 2)
   
5.     For i = 2 To UBound(arr) Step 2
   
6.         For j = 3 To UBound(arr, 2)
   
7.             If arr(i, j) <> Empty Then
   
8.                 m = m + 1
   
9.                 brr(m, 1) = arr(i, j)
   
10.                 brr(m, 2) = arr(i, 1)
    
11.             End If
    
12.         Next
    
13.     Next
    
14.     [o2:p1000] = ""
    
15.     [o2].Resize(m, 2) = brr
    
16.     MsgBox "OK！"
    
17. End Sub
    

复制代码

chxw68

练习。。。

longwin

参与一下：
Sub test()
    arr = [a1].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To 27 Step 2
        For j = 3 To 11
            If arr(i, j) <> "" Then
                d(arr(i, j)) = arr(i, 1)
            End If
        Next
    Next
    [O2].Resize(d.Count, 2) = WorksheetFunction.Transpose(Array(d.keys, d.items))
    st d = Nothing
End Sub

一招秒杀

这么简单的工作，复制 再 转置粘贴 几次不就好了吗？ 何必写什么代码？写代码和复制+转置粘贴，哪个更快？ 为什么总要做亏本的生意？代码一点阤不直观，远不如复制 再 转置粘贴 那么直观 高效 灵活 快速，不值得  根本不划算。

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, i&, j&, r&
   
    Application.ScreenUpdating = False
   
    ar = [A1].CurrentRegion.Value
    ReDim br(1 To UBound(ar) * UBound(ar, 2), 1)
    br(1, 0) = "教师": br(1, 1) = "学科": r = 1
   
    For i = 2 To UBound(ar) - 1 Step 2
        For j = 3 To UBound(ar, 2)
            If ar(i, j) <> 0 Then
                r = r + 1
                br(r, 0) = ar(i, j)
                br(r, 1) = ar(i, 1)
            End If
        Next j
    Next i
   
    If r Then [R1].Resize(r + 1, 2) = br
   
    Application.ScreenUpdating = True
    Beep
End Sub