vbscript 动态提取部分表

Posted 2021-05-21

Sub dym_extract1()
    sheet_source = ""
    sheet_target = ""
    '---
    Application.ScreenUpdating = False
    Sheets(sheet_target).Activate
    Sheets(sheet_target).Rows.Clear
    'extract---
    ii = 1
    With Sheets(sheet_source)
    For i = 2 To eu(65536, 1, sheet_source)
        If .Cells(i, fc("", , sheet_source)) <> "" Then
            Sheets(sheet_target).Cells(ii, 1).Formula = "=hyperlink(" & Chr(34) & _
            "#" & sheet_source & "!A" & i & Chr(34) & "," & Chr(34) & .Cells(i, j) & Chr(34) & ")"
            For j = 2 To 29
                Sheets(sheet_target).Cells(ii, j) = .Cells(i, j)
            Next
            Sheets(sheet_target).Rows(ii).RowHeight = 14.4
            ii = ii + 1
        End If
    Next
    End With
    Sheets(sheet_target).Columns(6).ColumnWidth = 22
    'sort---
    Sheets(sheet_target).Sort.SortFields.Clear
    Sheets(sheet_target).Sort.SortFields.Add Key:=Range("f:f") _
    , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    'ActiveWorkbook.Worksheets("data1").Sort.SortFields.Clear
    'ActiveWorkbook.Worksheets("data1").Sort.SortFields.Add Key:=Range("E2:E5"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With Sheets(sheet_target).Sort
        .SetRange Range("A1:Z" & Range("a65536").End(xlUp).Row)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    '---
    Application.ScreenUpdating = True
End Sub