使用excel vba，以特定模式将数据传输到另一个页面

Question

我想将用户从位于B4:M29范围内的下拉列表中选择的值传输到另一张具有特定图案的纸张上的B6:G56范围。使用此模式，“B”列/sheet1 中的值将成为“A”列/sheet5 中的标题，然后剩余的连续值将通过从中间移动到下一行而彼此跟随地进行传输。正如我尝试在下面示意性地展示的那样：

Sub Group6_Click()

   Dim wSheet As Worksheet

    Dim vFile As Variant

    Dim sFile As String

    Dim j As String

    Dim wb As Workbook

   

    Dim OldData As Range

    Dim NewData As Range

    Set OldData = ThisWorkbook.Sheets("sheet1").Range("B4:M29")

    Set NewData = ThisWorkbook.Sheets("sheet5").Range("A6:L31")

    Set wb = ThisWorkbook

        OldData.Value = NewData.Value

 

    Set wSheet = ActiveSheet

    sFile = Replace(Replace(wb.Name, "KV_Envanter", ""), ".", "_") _

            & "_" _

            & Format(Now(), "yyyymmdd\_hhmm") _

            & ".pdf"

    sFile = ThisWorkbook.Path & "\" & sFile

 

    vFile = Application.GetSaveAsFilename _

    (InitialFileName:=sFile, _

        FileFilter:="PDF Files (*.pdf), *.pdf", _

        Title:="Select Folder and FileName to save")

 

    If vFile <> "False" Then

 

MsgBox "The report is ready."

Sheets("sheet5").ExportAsFixedFormat Type:=xlTypePDF, _

Filename:=vFile, Quality:=xlQualityStandard, _

IncludeDocProperties:=True, IgnorePrintAreas:=False, _

OpenAfterPublish:=True

 

Sheets("sheet5").PageSetup.Orientation = xlLandscape

 

With ActiveSheet.PageSetup

    .LeftMargin = Application.InchesToPoints(0)

   .RightMargin = Application.InchesToPoints(0)

    .TopMargin = Application.InchesToPoints(0)

    .BottomMargin = Application.InchesToPoints(0)

    .FitToPagesWide = 1

End With

  

    End If

 

End Sub

Answer 1

Option Explicit
Sub demo()
    Dim oldData As Range, arrData, arrRes()
    Dim newData As Range
    Dim newColCnt As Integer, i As Long, j As Long, k As Long
    Dim oldColCnt As Integer
    Set oldData = ThisWorkbook.Sheets("sheet1").Range("B4:M29")
    arrData = oldData
    oldColCnt = UBound(arrData, 2)
    newColCnt = oldColCnt / 2 + 1
    ReDim arrRes(1 To UBound(arrData) * 2, 1 To newColCnt)
    k = 1
    For i = 1 To UBound(arrData)
        For j = 1 To newColCnt Step 1
            arrRes(k, j) = arrData(i, j)
            If j > 1 And j + newColCnt < oldColCnt + 2 Then
                arrRes(k + 1, j) = arrData(i, j + newColCnt - 1)
            End If
        Next
        k = k + 2
    Next
    Set newData = ThisWorkbook.Sheets("sheet5").Range("A6")
    newData.Resize(UBound(arrData) * 2, newColCnt).Value = arrRes
End Sub