[英]Copy Rows into columns using VBA
I have a very little experience with VBA, and I would really appreciate any help with this issue. 我对VBA的经验很少,并且非常感谢您提供有关此问题的帮助。 I need to convert rows into columns from sheet 1 to sheet 2. 我需要将行转换为从工作表1到工作表2的列。
Input File 输入文件
Desired Output 期望的输出
Sample data 样本数据
My Code 我的密码
Sub TransposeSpecial()
Dim lMaxRows As Long 'max rows in the sheet
Dim lThisRow As Long 'row being processed
Dim iMaxCol As Integer 'max used column in the row being processed
lMaxRows = Cells(Rows.Count, "A").End(xlUp).Row
lThisRow = 2 'start from row 2
Do While lThisRow <= lMaxRows
iMaxCol = Cells(lThisRow, Columns.Count).End(xlToLeft).Column
If (iMaxCol > 1) Then
Rows(lThisRow + 1 & ":" & lThisRow + iMaxCol - 1).Insert
Range(Cells(lThisRow, 2), Cells(lThisRow, iMaxCol)).Copy
Range("C" & lThisRow + 1).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Range(Cells(lThisRow, 2), Cells(lThisRow, iMaxCol)).Clear
lThisRow = lThisRow + iMaxCol - 1
lMaxRows = Cells(Rows.Count, "A").End(xlUp).Row
End If
lThisRow = lThisRow + 1
Loop
End Sub
Output obtained by Code 通过代码获得的输出
Desired output 所需的输出
Here you go, I made this flexible code. 在这里,我做了这个灵活的代码。 Just update the variables in the beginning. 只需在开始时更新变量。
Sub Transpose_my_cells()
Dim rng As Range
Dim sheet1, sheet2, addr As String
Dim src_top_row, src_left_col, dst_top_row, dst_left_col, data_cols, y As Integer
Application.ScreenUpdating = False
sheet1 = "Sheet1" 'Put your source sheet name here
sheet2 = "Sheet2" 'Put your destiny sheet name here
src_top_row = 1 'Put the top row number of the source here
src_left_col = 1 'Put the left col number of the source here
dst_top_row = 1 'Put the top row number of the destiny here
dst_left_col = 1 'Put the left col number of the destiny here
'Count data columns
data_cols = 0
Do Until Worksheets(sheet1).Cells(src_top_row, src_left_col + data_cols + 1) = ""
data_cols = data_cols + 1
Loop
'start copying data
With Worksheets(sheet1)
'first header
.Cells(src_top_row, src_left_col).Copy
addr = Cells(dst_top_row, dst_left_col).Address
Worksheets(sheet2).Range(addr).PasteSpecial
y = 0
'loop for each source row
Do Until .Cells(src_top_row + y + 1, src_left_col) = ""
'Create First column repetitions
.Cells(src_top_row + y + 1, src_left_col).Copy
addr = Cells(dst_top_row + y * data_cols + 1, dst_left_col).Address & ":" & Cells(dst_top_row + y * data_cols + data_cols, dst_left_col).Address
Worksheets(sheet2).Range(addr).PasteSpecial
'Transpose Data Headers
addr = Cells(src_top_row, src_left_col + 1).Address & ":" & Cells(src_top_row, src_left_col + data_cols).Address
.Range(addr).Copy
Worksheets(sheet2).Cells(dst_top_row + y * data_cols + 1, dst_left_col + 1).PasteSpecial Transpose:=True
'Transpose Data columns
Set rng = Cells(src_top_row + y + 1, src_left_col + 1)
addr = rng.Address & ":" & rng.Offset(0, data_cols - 1).Address
.Range(addr).Copy
Worksheets(sheet2).Cells(dst_top_row + y * data_cols + 1, dst_left_col + 2).PasteSpecial Transpose:=True
y = y + 1
Loop
End With
Application.ScreenUpdating = True
End Sub
Using VBA: 使用VBA:
Sub Transpose_my_cells()
Worksheets("Sheet1").Range("A1:E1").Copy
Worksheets("Sheet2").Range("A1").PasteSpecial Transpose:=True
End Sub
Notes: 笔记:
There is probably a much easier/cleaner way to do this but it works. 可能有一种更容易/更清洁的方法来执行此操作,但是它可以工作。 The way it's written now, it will take the data in Sheet1 and output the transposed data on Sheet2. 现在的编写方式将在Sheet1中获取数据,并在Sheet2中输出转置后的数据。 It should work as long as your data starts in cell A1. 只要您的数据在单元格A1中开始,它就应该起作用。
Option Explicit
Sub transpose()
Dim names() As String
Dim count As Long
Dim i As Long
Dim j As Long
Dim rng As Range
Dim tmp As Long
Sheets("Sheet1").Activate
count = 0
With ThisWorkbook.Sheets("Sheet1")
Do Until .Cells(1, 2 + count) = ""
count = count + 1
Loop
ReDim names(0 To count - 1)
count = 0
Do Until .Cells(1, 2 + count) = ""
names(count) = .Cells(1, 2 + count).Value
count = count + 1
Loop
.Range("A2").Activate
Set rng = Range(Selection, Selection.End(xlDown))
End With
j = 0
With ThisWorkbook.Sheets("Sheet2")
.Cells(1, 1).Value = "ID"
.Cells(1, 2).Value = "Name"
.Cells(1, 3).Value = "Value"
For i = 0 To rng.count * count - 1
If i Mod count = 0 Then
j = j + 1
Range(Cells(j + 1, 2), Cells(j + 1, count + 1)).Copy
.Cells(i + 2, 3).PasteSpecial transpose:=True
End If
.Cells(i + 2, 1).Value = rng(j).Value
.Cells(i + 2, 2).Value = names(i Mod count)
Next i
.Activate
End With
End Sub
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.