Columns to columns

doug5jmp

Board Regular
Joined
Apr 27, 2010
Messages
62
I than would have to enter a code in each of the two "source" files for each location and than into the destination file, correct?

Whereby the first source file has a submit button to the aggregate source file,
And the destination file has an update button to pull from the aggregate source file.

Which would be...
 

Some videos you may like

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.

snowblizz

Well-known Member
Joined
Mar 16, 2009
Messages
1,123
I just looked quickly through the previous posts as I've been struggling a bit with this following code.
It represents the code needed for importing all columns, from all listed workbooks. I haven't quite managed to test it thoroughly but it seems to work. This goes into the destination workbook.

So in essence after running all the previous posted code from all data sheets running this one should produce the same result.

Code:
Sub datacopyAll()
Application.ScreenUpdating = False

Set listSht = ThisWorkbook.Sheets("Sheet3")  'destination sheet
Dim WkBArray()
WkBArray = Array("BookTest.xls", "BookTest2.xls") 'list all the workboks to be used

LastCol2 = listSht.Cells.Find("*", Cells(Rows.Count, Columns.Count), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
LastRow = listSht.Cells.Find("*", Cells(Rows.Count, Columns.Count), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Row
listSht.Range(listSht.Cells(1, 2), listSht.Cells(LastRow, LastCol2)).ClearContents

For Each wkBfileName In WkBArray 'loop through all listed workbooks
Set wkB = Workbooks.Open(wkBfileName)
For Each wkS In wkB.Worksheets 'loop through all worksheets in opened workbook.
Set DataSht = wkS
LastCol = DataSht.Cells.Find("*", Cells(Rows.Count, Columns.Count), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

    For Col = 2 To LastCol - 2 'loops through all columns in source sheet from column B to the last column used
    LastCol2 = listSht.Cells.Find("*", Cells(Rows.Count, Columns.Count), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column 'finds last used column in destination
        If DataSht.Cells(1, Col).Value <> "" Then 'test for an empty column, assumes any column with empty cell in row 1 is empty
        DataSht.Columns(Col).Copy 'copies whole column
        listSht.Columns(LastCol2 + 1).PasteSpecial (xlPasteValuesAndNumberFormats) 'pastes numbers and formats to the destination sheet
        End If
    Next Col
  Next wkS
  Application.CutCopyMode = False
  wkB.Close
Next wkBfileName

LastCol2 = listSht.Cells.Find("*", Cells(Rows.Count, Columns.Count), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
LastRow = listSht.Cells.Find("*", Cells(Rows.Count, Columns.Count), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Row
 With listSht
 If LastCol2 <> 2 Then ' checks whether a sort is neded, if so sorts by date header
 .Range(.Cells(1, 2), .Cells(LastRow, LastCol2)).Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight, _
        DataOption1:=xlSortNormal
End If
If .Cells(1, LastCol2).Value = "YTD" Then 'checks whether YTD header is present
i = 0
j = -1
Else 'if not present creates it
.Cells(1, LastCol2 + 1).Value = "YTD"
i = 1
j = 0
End If
'updates YTD formulas
.Range(.Cells(2, LastCol2 + i), .Cells(LastRow, LastCol2 + i)).FormulaR1C1 = "=SUM(R" & Row & "C2:R" & Row & "C" & LastCol2 + j & ")"
End With
ThisWorkbook.Save 'saves source workbook
Application.ScreenUpdating = True 'turns screen updating back on
ThisWorkbook.Close False 'closes source workbook
End Sub
 

snowblizz

Well-known Member
Joined
Mar 16, 2009
Messages
1,123
I would avoid additional workbooks and worksheets.
As I said I think Excel will check the read/write capacity of the opened workbook.
The code could test the read write status and abort the copy if the destination is unwritable and ask the user to wait before trying again.
 

doug5jmp

Board Regular
Joined
Apr 27, 2010
Messages
62
'THIS WILL GO INTO THE DESTINATION WORKBOOK ONLY

Code:
Sub datacopyAll()
Application.ScreenUpdating = False

Set listSht = ThisWorkbook.Sheets("Sheet3")  'destination sheet
Dim WkBArray()
WkBArray = Array("BookTest.xls", "BookTest2.xls") 'list all the workboks to be used

LastCol2 = listSht.Cells.Find("*", Cells(Rows.Count, Columns.Count), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
LastRow = listSht.Cells.Find("*", Cells(Rows.Count, Columns.Count), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Row
listSht.Range(listSht.Cells(1, 2), listSht.Cells(LastRow, LastCol2)).ClearContents

For Each wkBfileName In WkBArray 'loop through all listed workbooks
Set wkB = Workbooks.Open(wkBfileName)
For Each wkS In wkB.Worksheets 'loop through all worksheets in opened workbook.
Set DataSht = wkS
LastCol = DataSht.Cells.Find("*", Cells(Rows.Count, Columns.Count), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

    For Col = 2 To LastCol - 2 'loops through all columns in source sheet from column B to the last column used
    LastCol2 = listSht.Cells.Find("*", Cells(Rows.Count, Columns.Count), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column 'finds last used column in destination
        If DataSht.Cells(1, Col).Value <> "" Then 'test for an empty column, assumes any column with empty cell in row 1 is empty
        DataSht.Columns(Col).Copy 'copies whole column
        listSht.Columns(LastCol2 + 1).PasteSpecial (xlPasteValuesAndNumberFormats) 'pastes numbers and formats to the destination sheet
        End If
    Next Col
  Next wkS
  Application.CutCopyMode = False
  wkB.Close
Next wkBfileName

LastCol2 = listSht.Cells.Find("*", Cells(Rows.Count, Columns.Count), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
LastRow = listSht.Cells.Find("*", Cells(Rows.Count, Columns.Count), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Row
 With listSht
 If LastCol2 <> 2 Then ' checks whether a sort is neded, if so sorts by date header
 .Range(.Cells(1, 2), .Cells(LastRow, LastCol2)).Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight, _
        DataOption1:=xlSortNormal
End If
If .Cells(1, LastCol2).Value = "YTD" Then 'checks whether YTD header is present
i = 0
j = -1
Else 'if not present creates it
.Cells(1, LastCol2 + 1).Value = "YTD"
i = 1
j = 0
End If
'updates YTD formulas
.Range(.Cells(2, LastCol2 + i), .Cells(LastRow, LastCol2 + i)).FormulaR1C1 = "=SUM(R" & Row & "C2:R" & Row & "C" & LastCol2 + j & ")"
End With
ThisWorkbook.Save 'saves source workbook
Application.ScreenUpdating = True 'turns screen updating back on
ThisWorkbook.Close False 'closes source workbook
End Sub
[/QUOTE]



...this code will be placed in the source workbook, in a code module.
It opens the destination workbook, copies over the last column, sorts and updates the destination YTD and closes and saves both workbooks.
'FOR THE WORKBOOKS WITH ONE WORKSHEET

Code:
Sub datacopySingle()
Application.ScreenUpdating = False
Set listWkB = Workbooks.Open("BookTest.xls") 'destiantion workbook
Set listsht = listWkB.Sheets("Sheet3")  'destination sheet
Set datasht = Workbooks(ThisWorkbook.Name).Activesheet  'source sheet, will always be the active sheet ie the one the button is placed on

LastCol = datasht.Cells.Find("*", Cells(Rows.Count, Columns.Count), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
LastCol2 = listsht.Cells.Find("*", Cells(Rows.Count, Columns.Count), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

    datasht.Columns(LastCol - 2).Copy
    listsht.Columns(LastCol2 + 1).PasteSpecial (xlPasteValuesAndNumberFormats)

Application.CutCopyMode = False
LastCol2 = listsht.Cells.Find("*", Cells(Rows.Count, Columns.Count), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
LastRow = listsht.Cells.Find("*", Cells(Rows.Count, Columns.Count), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Row

 With listsht
 If LastCol2 <> 2 Then ' checks whether a sort is neded, if so sorts by date header
 .Range(.Cells(1, 2), .Cells(LastRow, LastCol2)).Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight, _
        DataOption1:=xlSortNormal
End If
If .Cells(1, LastCol2).Value = "YTD" Then 'checks whether YTD header is present
i = 0
j = -1
Else 'if not present creates it
.Cells(1, LastCol2 + 1).Value = "YTD"
i = 1
j = 0
End If
'updates YTD formulas
.Range(.Cells(2, LastCol2 + i), .Cells(LastRow, LastCol2 + i)).FormulaR1C1 = "=SUM(R" & Row & "C2:R" & Row & "C" & LastCol2 + j & ")"
End With
ThisWorkbook.Save 'saves source workbook
listWkB.Save 'saves destination workbook
listWkB.Close False 'closes destination workbook
Application.ScreenUpdating = True 'turns screen updating back on
ThisWorkbook.Close False 'closes source workbook
End Sub
Then when you create the button on each sheet use the following code for the button click.
Code:
Call datacopySingle
It would be better to just keep pushing YTD "outwards" by inserting a new column for the user to enter data in.
'WOULD THIS HAVE TO BE DONE BY THE PERSON OR AFTER THE DATA IS SAVED THE WORKSHEET PUSHES THE YTD TWO COLUMNS FROM THE LAST DATA ENTERED?'

The code will also require there be headers for column A in the destination workbook. The .Find method will not work if the destination workbook is completely empty.
'WHAT WOULD THE HEADERS BE FOR THE DATES? AS THE DATE IS IN ITSELF THE HEADER?

This will take all the sheets in a workbook and copy the last column from each and paste it to the destination workbook, sort everything by date. And then save and close both workbooks. Also placed in a module in the source worksheet.
'FOLLOWING CODE IS FOR THE WORKBOOK WITH MULTIPLE WORKSHEETS, SO SHOULD THE BUTTON BE
Code:
 Call datacopyMultiSingle

Code:
Sub datacopyMultiSingle()
Application.ScreenUpdating = False
Set listWkB = Workbooks.Open("BookTest.xls", Notify:=True) 'destiantion workbook
Set listsht = listWkB.Sheets("Sheet3")  'destination sheet

For Each wkS In ThisWorkbook.Worksheets
Set datasht = wkS  'source sheet
LastCol = datasht.Cells.Find("*", Cells(Rows.Count, Columns.Count), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
LastCol2 = listsht.Cells.Find("*", Cells(Rows.Count, Columns.Count), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

    datasht.Columns(LastCol - 2).Copy
    listsht.Columns(LastCol2 + 1).PasteSpecial (xlPasteValuesAndNumberFormats)
Next
Application.CutCopyMode = False
LastCol2 = listsht.Cells.Find("*", Cells(Rows.Count, Columns.Count), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
LastRow = listsht.Cells.Find("*", Cells(Rows.Count, Columns.Count), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Row

 With listsht
 If LastCol2 <> 2 Then ' checks whether a sort is neded, if so sorts by date header
 .Range(.Cells(1, 2), .Cells(LastRow, LastCol2)).Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight, _
        DataOption1:=xlSortNormal 'sorts the columns starting from column B, row 1
End If
If .Cells(1, LastCol2).Value = "YTD" Then 'checks whether YTD header is present in row 1, column [whatever the last column is]
i = 0
j = -1
Else 'if not present creates it
.Cells(1, LastCol2 + 1).Value = "YTD"
i = 1
j = 0
End If
'updates YTD formulas
.Range(.Cells(2, LastCol2 + i), .Cells(LastRow, LastCol2 + i)).FormulaR1C1 = "=SUM(R" & Row & "C2:R" & Row & "C" & LastCol2 + j & ")"
End With
ThisWorkbook.Save 'saves source workbook
listWkB.Save 'saves destination workbook
listWkB.Close False 'closes destination workbook
Application.ScreenUpdating = True 'turns screen updating back on
ThisWorkbook.Close False 'closes source workbook
End Sub
'WITH THE ADDED BUTTON, CAN IT BE ALTERED? AS STATED BEFORE SHOW RED OR GREEN ETC.? ALSO CAN WE USE AN IMG SOURCE FOR THE BUTTON?
 

Forum statistics

Threads
1,089,600
Messages
5,409,221
Members
403,256
Latest member
Viq

This Week's Hot Topics

  • help please
    SORRY NOT ANY GOOD AT EXCEL SO HELP WOULD BE MUCH APPRECIATED this formula is in a sheet called ignore...
  • two formulas needed
    Hello, I'll try my best to explain this: First formula needed in Sheet1 cell A2: If Sheet1 cell B2 = Sheet2 cell B2 then return a 1. If not then...
  • Dynamic Counts
    Good afternoon, we are tidying up some data & the data seems to be growing quicker than we are tidying it up! What we confirm (by reviewing it...
  • Help Excel formula eliminate duplicate values and keep only 2 identical rows.
    as picture below column A has a duplicate value. but the values are not the same as the rule. sometimes 4 rows, sometimes 10 rows or 7 or 9...
  • Macro Compile Error Sub or Function not defined
    Hello, I am trying to run macros from a validation list, all macros have been created and run perfectly on there own but I'm getting a compile...
  • Last row combined with Current Region VBA
    I'm generally happy finding the last row of data through something like Lastrow = Cells(Rows.Count, "D").End(xlUp) but I don't always receive data...
Top