移调列使用VBA Excel表格

Sub TransposeColsToSheets()

'varibles

Dim wb As Workbook

Dim twb As Workbook

Dim lstRw As Integer

Dim lstCl As Integer

Dim cols As Range

With Application

.DisplayAlerts = False

.ScreenUpdating = False

End With

'creating new file

Set wb = Workbooks.Add

'saving the file. Replace the path with your destination.

wb.SaveAs "C:\Users\Manish Singh\Desktop\Excel Tip\result.xlsx"

Set twb = ThisWorkbook

twb.Sheets(1).Activate

lstCl = Cells(1, Columns.Count).End(xlToLeft).Column

'identfying headers for city names

Set cols = Range(Cells(1, 1), Cells(1, lstCl))

'loop to create sheets

For x = 1 To cols.Count

wb.Sheets.Add.Name = "page" & x

Next

'loop to transpose columns to sheets

For Each sh In twb.Sheets

For x = 1 To cols.Count

sh.Activate

lstRw = Cells(Rows.Count, 1).End(xlUp).Row

Range(Cells(1, x), Cells(lstRw, x)).Copy

wb.Sheets("page" & x).Activate

lstCl = Cells(1, Columns.Count).End(xlToLeft).Column + 1

Range(Cells(1, lstCl), Cells(1, lstCl)).PasteSpecial xlPasteAll

Next x

Next sh

'saving and closing the result workbook

wb.Save

wb.Close

With Application

.DisplayAlerts = True

.ScreenUpdating = True

End With

End Sub

'loop to create sheets

For x = 1 To cols.Count

wb.Sheets.Add.Name = "page" & x

Next