怎么根据名单新增列数与填入对应内容

979595410

如何可以快速根据名单表上到内容在直接上级表和间接上级表新增列数，然后按照内容填入对应的单元格。名单长度不固定的。然后另存为名称改为名单表b5单元格内容&填写测试，（张三填写测试）

liulang0808

建议楼主结合附件内容，将需求结果模拟出来，并明确实现步骤啊

979595410

liulang0808 发表于 2023-1-3 18:38
建议楼主结合附件内容，将需求结果模拟出来，并明确实现步骤啊

例如直接上级表d3单元格，填入名单表b4内容，直接上级表h6填入名单表b7，根据名单表b7:b25的内容新增列。已经上传效果图3

liulang0808

Sub 按钮1_Click()
    Application.ScreenUpdating = False
   
    With Sheets("直接上级")
        .[d3] = [b4]
        .[h2] = [b5]
        r = Cells(Rows.Count, 2).End(3).Row
        .[d2] = Join(WorksheetFunction.Transpose(Range("b7:b" & r)), "、")
    End With
    With Sheets("间接上级")
        .[d3] = [c4]
        .[h2] = [c5]
        r = Cells(Rows.Count, 3).End(3).Row
        .[d2] = Join(WorksheetFunction.Transpose(Range("c7:c" & r)), "、")
    End With
    Application.ScreenUpdating = True
End Sub

liulang0808

模拟供参考。。。。。。。

979595410

liulang0808 发表于 2023-1-3 19:02
模拟供参考。。。。。。。

是标绿色的地方需要按照名单表的内容相对于填入，然后重命名薄名称，版主可以帮忙再改一下吗?

liulang0808

Sub 按钮1_Click()
    Application.ScreenUpdating = False
    r = Sheets("名单").Cells(Rows.Count, 2).End(3).Row
    arr = Sheets("名单").Range("b7:b" & r)
    Sheets("原始表").Copy after:=Sheets(1)
    With Sheets(2)
        .Name = "直接上级"
        .[d3] = Sheets("名单").[b4]
        .[h2] = Sheets("名单").[b5]
        .[d2] = Join(WorksheetFunction.Transpose(arr), "、")
        .Cells(6, 8) = arr(1, 1)
        For j = UBound(arr) - 1 To 1 Step -1
            .Columns(8).Insert
            .Cells(5, 9).Resize(2).Copy .Cells(5, 8)
            .Cells(2, 8).Resize(1, 4).Merge
            .Cells(3, 8).Resize(1, 4).Merge
            .Cells(6, 8) = arr(j, 1)
        Next j
    End With

    Application.ScreenUpdating = True
End Sub

liulang0808

模拟了一个，供参考。。。。。。

3190496160

Sub 新建工作表()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Application.DisplayAlerts = False
For Each sh In Sheets
    If sh.Index > 2 Then
        sh.Delete
    End If
Next sh
Application.DisplayAlerts = True
With Sheets("名单")
    r = .Cells(Rows.Count, 2).End(xlUp).Row
    ar = .Range("b7:b" & r)
    rs = .Cells(Rows.Count, 3).End(xlUp).Row
    br = .Range("c7:c" & rs)
    xm = .[b3]
    bm = .[b2]
    zw = .[b5]
End With
Sheets("原始表").Copy after:=Sheets(Sheets.Count)
With ActiveSheet
    .Name = xm & "直接上级填写测试"
    sl = r - 7
    ls = 8 + sl
    lh = Chr(ls + 64)
    .Columns("I:" & lh).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    .Cells(5, 8).Resize(1, sl + 1) = "评分"
    .Cells(6, 8).Resize(1, sl + 1) = Application.Transpose(ar)
End With
Sheets("原始表").Copy after:=Sheets(Sheets.Count)
With ActiveSheet
    .Name = xm & "间接上级填写测试"
    sl = rs - 7
    ls = 8 + sl
    lh = Chr(ls + 64)
    .Columns("I:" & lh).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    .Cells(5, 8).Resize(1, sl + 1) = "评分"
    .Cells(6, 8).Resize(1, sl + 1) = Application.Transpose(br)
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

张三填写测试.rar (16.31 KB, 下载次数: 3)

2023-1-4 11:07 上传

点击文件名下载附件