问个问题啊

下面这个函数是循环取行的，把第一行和每3行复制到新工作簿中，怎么改成第一列和每三列啊
Sub 循环取行
Dim wb, I%, J%
Dim RowArr() As Integer, IsSave As Boolean
Application.ScreenUpdating = False
J = 2
Do While Len(Range("A" & J)) > 0 '从第2行开始循环取行
I = 3
Do While Range("A" & J) = Range("A" & J + 1)
I = I + 1
Loop
Range("1:1," & J & ":" & J + I).Copy '将表头和相应行一起复制
' Union(Rows(1), Rows(J)).Copy '将表头和相应行一起复制
Set wb = Workbooks.Add '新建一个工作簿
wb.Sheets(1).Paste '将复制的内容粘贴
On Error Resume Next
Kill ThisWorkbook.Path & "\" & wb.Sheets(1).Range("A2") & ".xlsx" '先把同路径下同名的文件删除，防止报错
wb.SaveAs ThisWorkbook.Path & "\" & wb.Sheets(1).Range("A2") & ".xlsx" '保存工作簿，以新工作簿的A2单元格为名
wb.Close '关闭工作簿
Set wb = Nothing '释放wb
J = J + 1 + I
Loop
Application.ScreenUpdating = True
End Sub