Это решение было существенно переписано в свете пересмотренного вопроса.
В этом решении предполагается, что макрос SplitSheet находится в собственной рабочей книге. В этой версии необходимо два имени файла, жестко закодированных как Source.xls и Dest.xls . В этой версии предполагается, что все три книги находятся или будут в одной папке. Исходная рабочая книга должна существовать до запуска макроса. Книга назначения не должна существовать.
Вопрос состоит из четырех столбцов, но настоящая проблема имеет шестьдесят. Решение рассчитано на изменение размеров до Sheet1 (также жестко закодировано). Какие столбцы должны быть перемещены, куда и как именуются, управляются тремя массивами, которые могут быть увеличены из их текущих трех записей. Код использует фактический размер этих массивов.
Я надеюсь, что каждое трудное утверждение полностью объяснено. Желаем удачи.
Sub SplitSheet()
Dim ColDestCrnt As Integer
Dim ColMapName() As Variant
Dim ColMapDest() As Variant
Dim ColMapSource() As Variant
Dim ColSourceCrnt As Integer
Dim ColSourceMax As Integer
Dim ColWidth() As Single
Dim DataCol() As Variant
Dim DataWSheet() As Variant
Dim FileNameSource As String
Dim FileNameDest As String
Dim InxColMap As Integer
Dim InxWSheet As Integer
Dim Path As String
Dim Rng As Range
Dim RowSourceCrnt As Integer
Dim RowSourceMax As Integer
Dim WBookDest As Workbook
Dim WBookSource As Workbook
' These arrays define the mappings. Column B is to be copied to column A,
' column C to C and column E to D.
ColMapSource = Array("B", "C", "E")
ColMapDest = Array("A", "C", "D")
' The names to be given to the worksheets in the destination worksheet
ColMapName = Array("Company", "Address", "Popularity")
' Additional entries may be added to these array providing they all have
' the same number of entries.
If Workbooks.Count > 1 Then
' It can get complicated if more than one workbook is open
' at the start. I suggest aborting in this situation unless
' there is an important reason for allowing it.
' If this is a one-off transformation, use of Debug.Assert False,
' which will stop execution until you press F5, is adequate if
' unprofessional. If it is to be used repeatedly, you need a
' proper error message for the user.
Debug.Assert False ' execution error
Exit Sub
End If
' This assumes all three workbooks will be in the same folder.
' Change as necessary.
Path = ActiveWorkbook.Path
' You must decide how to assign values to these variables
FileNameSource = "Source.xls"
FileNameDest = "Dest.xls"
If Dir$(Path & "\" & FileNameSource) = "" Then
' Source workbook does not exist
Debug.Assert False ' execution error
Exit Sub
End If
If Dir$(Path & "\" & FileNameDest) <> "" Then
' Dest workbook exists
Debug.Assert False ' execution error
Exit Sub
End If
Set WBookSource = Workbooks.Open(Path & "\" & FileNameSource)
With WBookSource
' Replace "Sheet1" with the name of the source worksheet
With Sheets("Sheet1")
' This determines the highest numbered row and the highest
' number column in the source worksheet
Set Rng = .Range("A1").SpecialCells(xlCellTypeLastCell)
RowSourceMax = Rng.Row
ColSourceMax = Rng.Column
' This copies the values of the entire source worksheet to array SourceWSheet
DataWSheet = .Range(.Cells(1, 1), .Cells(RowSourceMax, ColSourceMax)).Value
' This saves the widths of the source columns
ReDim ColWidth(1 To ColSourceMax)
For ColSourceCrnt = 1 To ColSourceMax
ColWidth(ColSourceCrnt) = .Columns(ColSourceCrnt).ColumnWidth
Next
End With
' We have no further need of the source workbook. Close without saving
.Close False
End With
Set WBookSource = Nothing
' DataWSheet has dimensions (1 to RowSourceMax, 1 to ColSourceMax)
' Normal practice is to have rows as the second dimension. This is not true
' of array loaded from or to a worksheet.
Set WBookDest = Workbooks.Add
With WBookDest
' The factory setting for Excel is to have three sheets
' in a new workbook but that setting may be changed.
' This Do Loop ensures there are enough sheets and that
' any that are added are in sheet name sequence.
' It does not delete any excess Sheets.
Do While UBound(ColMapName) > .Sheets.Count
.Sheets.Add After:=Sheets(.Sheets.Count)
Loop
' Name the sheets with the values in ColMapName() and set the
' width of the destination column to that of the source column.
' The use of lbound (=lower bound) and ubound (=upper bound)
' means this for-loop is controlled by the size of ColmapName.
' Note one index is used for all three ColMap arrays because they match
For InxColMap = LBound(ColMapName) To UBound(ColMapName)
' ColMapName has been loaded with Array. Its lower bound is almost
' certainly zero but the documentation is not 100% clear that it will
' always be zero. The lower bound for sheets is one.
' "InxColMap + 1 - LBound(ColMapName)" performs the necessary adjustment
' regardless of the ColMapName's lower bound
With .Sheets(InxColMap + 1 - LBound(ColMapName))
.Name = ColMapName(InxColMap)
' Convert the column letters in ColMapSource and ColMapDest
' to numbers. Bit of a cheat but it works.
ColSourceCrnt = Range(ColMapSource(InxColMap) & "1").Column
ColDestCrnt = Range(ColMapDest(InxColMap) & "1").Column
.Columns(ColDestCrnt).ColumnWidth = ColWidth(ColSourceCrnt)
End With
Next
' The destination worksheets are now prepared.
' Size the array that will be used to copy data to the destination sheets
ReDim DataCol(1 To RowSourceMax, 1 To 1)
For InxColMap = LBound(ColMapSource) To UBound(ColMapSource)
ColSourceCrnt = Range(ColMapSource(InxColMap) & "1").Column
For RowSourceCrnt = 1 To RowSourceMax
DataCol(RowSourceCrnt, 1) = DataWSheet(RowSourceCrnt, ColSourceCrnt)
Next
With Sheets(ColMapName(InxColMap))
' Copy data to appropriate column in appropriate destination sheet
.Range(ColMapDest(InxColMap) & "1:" & _
ColMapDest(InxColMap) & RowSourceMax).Value = DataCol
End With
Next
.SaveAs (Path & "\" & FileNameDest)
.Close False
End With
Set WBookDest = Nothing
End Sub