还是求助表格拆分

ykcbf1100

sunny_8848 发表于 2024-11-14 16:46
谢谢您的帮忙，因为表格里面有些公式，所以要先把公式改成数值，但要保持总表的公式

你这不是矛盾吗？既要保留公式，又要转换成数值。

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, i&, Rng As Range, Rng2 As Range, strFileName$, strPath$

    Application.DisplayAlerts = False
    Application.ScreenUpdating = True
   
    strPath = ThisWorkbook.Path & "\"
    With [A1].CurrentRegion
        ar = .Value
        Set Rng = .Rows(1)
        For i = 2 To UBound(ar)
             Set Rng2 = .Rows(i)
             With Workbooks.Add
                 strFileName = strPath & ar(i, 1)
                 With Worksheets(1)
                     rngCopyToSame Rng, .[A1]
                     Rng2.Copy .[A2]
                     .[A1].CurrentRegion.Value = .[A1].CurrentRegion.Value
                 End With
                 .SaveAs strFileName: .Close
             End With
        Next i
    End With
   
    Set Rng = Nothing: Set Rng2 = Nothing
    Application.DisplayAlerts = False
    Application.ScreenUpdating = True
    Beep
End Sub
Function rngCopyToSame(ByVal rngSel As Range, ByVal rngTarget As Range)
    Dim i&
    rngSel.Copy
    rngTarget.PasteSpecial xlPasteColumnWidths
    rngSel.Copy rngTarget
    With rngTarget.Resize(rngSel.Rows.Count, rngSel.Columns.Count)
        For i = 1 To .Rows.Count
            .Rows(i).RowHeight = rngSel.Rows(i).RowHeight
        Next i
    End With
End Function

gwjkkkkk

sunny_8848 发表于 2024-11-14 16:46
谢谢您的帮忙，因为表格里面有些公式，所以要先把公式改成数值，但要保持总表的公式

请参考。。。

sunny_8848

ykcbf1100 发表于 2024-11-14 17:43
你这不是矛盾吗？既要保留公式，又要转换成数值。

是我没说清楚，总表不保存就行了

sunny_8848

gwjkkkkk 发表于 2024-11-14 18:30
请参考。。。

谢谢帮忙。我开始没说清楚，有公式需要先处理成数值，拆分后总表不保存，重新打开后公式还在

sunny_8848

谢谢大家的帮忙。我开始没有说清楚条件，总表有些单元格有公式，所以先要转换成数值再拆分，总表不保存就可以了

gwjkkkkk

sunny_8848 发表于 2024-11-14 19:06
谢谢帮忙。我开始没说清楚，有公式需要先处理成数值，拆分后总表不保存，重新打开后公式还在

就是这样，不处理总表公式，只对折分后的分表改成数值，你可以试一下。。。

sunny_8848

gwjkkkkk 发表于 2024-11-14 18:30
请参考。。。

其实总表中绿色表格是有公式的，运行结果不对

gwjkkkkk

sunny_8848 发表于 2024-11-14 20:30
其实总表中绿色表格是有公式的，运行结果不对

再改一下。。。

sunny_8848

gwjkkkkk 发表于 2024-11-14 20:41
再改一下。。。

谢谢多次帮忙，效果很好