I have data in one sheet in a workbook. I want to distribute it across multiple sheets in a another book. How to do it, here is the diagram.
Currently I am using the following code but it does not work the way it is suppose too. This is just a starting point for me.
Dim row1, row2 Dim i As Integer Dim cell1 As String ' this is just an example where I am trying to loop through 3 cells but it does not work ' the cells in my example are in G14,G15 and G16 Dim wbk1 As Workbook, wbk2 As Workbook strFirstFile = "c:\Book1.xls" strSecondFile = "c:\Book2.xls" Set wbk1 = Workbooks.Open(strFirstFile) Set wbk2 = Workbooks.Open(strSecondFile) For i = 14 To 16 With wbk1.Sheets("Data") Cells(i, 7).Copy End With With wbk2.Sheets("MyData") Cells(i, 5).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False End With Next i
The actual mapping in my example is like this
Book1.xls Book2.xls sheet1->B3 -> Company->A3 sheet1->C3 -> Address->C3 sheet1->E3 -> Popularity->D3
If I can achieve this, my actual project is almost the same.
This solution has been sustantially rewritten in light of the revised question.
This solution assumes the macro SplitSheet is in its own workbook. Its needs two file names which are hard coded as Source.xls and Dest.xls in this version. This versions assumes all three workbooks are or will be in the same folder. The source workbook must exist before the macro is run. The destination workbook must not exist.
The question has four columns but the real problem has sixty. The solution is designed to resize to the dimensions of Sheet1 (also hard coded). Which columns are to be moved, where to and how named are controlled by three arrays which can be enlarged from their current three entries. The code uses the actual size of these arrays.
I hope that every difficult statement is fully explained. Best of luck.
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