Excel VBA: Copy columns from workbook to new workbook - vba

I'm not really great at coding so as much help as possible would be incredible. Basically here's what I want to do.
Export CSV from Website (No code required)
Open CSV in Excel (No code required)
Automatically remove rows that have a blank cell in certain column (Already coded)
Copy specific columns (ignoring header rows) to another workbook in specific order.
Column order is as follows: (S1 = Open CSV || S2 = New Workbook)
S1.V = S2.A
S1.B = S2.D
S1.F = S2.V
S1.H = S2.X
S1.I = S2.J
S1.L = S2.B
Step 3's code:
Columns("V:V").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete

There is a lot to consider when doing what you require, I have made some assumptions that you will need to code for if they are incorrect: -
The destination already exists
The destination has headers on row 1 but no content
The destination is simply the first sheet in the destination workbook
The source header row is row 1
Sample code: -
Public Sub Sample()
Dim StrDestPath As String
Dim WkBk_Dest As Workbook
Dim WkBk_Src As Workbook
Dim WkSht_Dest As Worksheet
Dim WkSht_Src As Worksheet
'A reference to the destination
StrDestPath = "C:\Users\Gary\Desktop\Destination.xlsx"
'Connect to the source
Set WkBk_Src = ThisWorkbook
Set WkSht_Src = WkBk_Src.Worksheets(1)
'See if the destination is open already
For Each WkBk_Dest In Application.Workbooks
If WkBk_Dest.FullName = StrDestPath Then Exit For
Next
'If it wasn't then open it
If WkBk_Dest Is Nothing Then
Set WkBk_Dest = Application.Workbooks.Open(StrDestPath)
End If
'Connect to the destination
Set WkSht_Dest = WkBk_Dest.Worksheets(1)
'Per column mapping - Copy everythng from row 2 (assuming headers are on row 1 down to the last populated cell in that column
'and paste it into the required column in the destination
WkSht_Src.Range("V2:" & WkSht_Src.Range("V2").End(xlDown).Address).Copy WkSht_Dest.Range("A2")
WkSht_Src.Range("B2:" & WkSht_Src.Range("B2").End(xlDown).Address).Copy WkSht_Dest.Range("D2")
WkSht_Src.Range("F2:" & WkSht_Src.Range("F2").End(xlDown).Address).Copy WkSht_Dest.Range("V2")
WkSht_Src.Range("H2:" & WkSht_Src.Range("H2").End(xlDown).Address).Copy WkSht_Dest.Range("X2")
WkSht_Src.Range("I2:" & WkSht_Src.Range("I2").End(xlDown).Address).Copy WkSht_Dest.Range("J2")
WkSht_Src.Range("L2:" & WkSht_Src.Range("L2").End(xlDown).Address).Copy WkSht_Dest.Range("B2")
'Disconnect from destination worksheet
Set WkSht_Dest = Nothing
'save changes
WkBk_Dest.Save
'disconnect from destination workbook
Set WkBk_Dest = Nothing
'Disconnect from source
Set WkSht_Src = Nothing
Set WkBk_Src = Nothing
End Sub
I have also assumed the source to be the workbook I was coding in, this won't be possible in a CSV file so you might want to open it in the same way the destination is checked for and then opened, you also may want to add a flag to close them when done if they were not opened to begin with.
Finally, if the destination already has data use the .end function as shown in the sample to get the the last row.

since you're working from CSV file, you don't have formats to carry along
therefore simple values pasting is what you need
try this
Option Explicit
Sub CopyColumnsToAnotherWB(sourceWS As Worksheet, targetWs As Worksheet, sourceCols As String, targetCols As String)
Dim sourceColsArr As Variant, targetColsArr As Variant
Dim iCol As Long, nCols As Long
sourceColsArr = Split(Application.WorksheetFunction.Trim(sourceCols), ",") '<--| make array out of string with delimiter
targetColsArr = Split(Application.WorksheetFunction.Trim(targetCols), ",") '<--| make array out of string with delimiter
nCols = UBound(sourceColsArr) '<--| count columns number to copy/paste
If nCols <> UBound(targetColsArr) Then Exit Sub '<--| exit if the two columns list haven't the same number of columns
With sourceWS
For iCol = 0 To nCols '<--|loop through source sheet columns
With .Cells(1, sourceColsArr(iCol)).Resize(.Cells(.Rows.Count, sourceColsArr(iCol)).End(xlUp).Row)
targetWs.Columns(targetColsArr(iCol)).Resize(.Rows.Count).value = .value '<--|paste values to corresponding target sheet column
End With
Next iCol
End With
End Sub
which you can exploit as follows
Option Explicit
Sub main()
Dim sourceCols As String, targetCols As String
sourceCols = "V,B,F,H,I,L"
targetCols = "A,D,V,X,J,B"
CopyColumnsToAnotherWB ActiveWorkbook.ActiveSheet, Workbooks("columntest").Worksheets("test"), sourceCols, targetCols
End Sub
just change ActiveWorkbook.ActiveSheet and Workbooks("columntest").Worksheets("test") to your actual source and target workbooks and worksheets

Related

Get data from another excel file with not fixed worksheet name

I have a excel file that contain daily order id and I need to get some data from other excel use the order id as index. The source file contain many worksheet that means a listbox with sheet name for selection is required.
The workbook & worksheet used for data source is not fixed and will determine by user, so a listbox for user to select relevant worksheet is required
The workflow is when i call the vba at the daily excel file, a listbox with all sheet name of the source excel file will pop up for select worksheet, then the daily excel file will get data from the source excel base on the order id as index.
Now I have a vba using activeworkbook and activeworksheet to set the lookup range, but I don't think this is a good coding method. Could someone can give me some suggestion?
For the userform code if the strfile is set to an exact file the code is fine, but the source file may be change.
All source files are save in same location, the required source file name is in Range("Z1") of the daily excel file, is it possible the strfile can change base on Range("Z1")?
Please let me know if I can clarify anything for you.
Sub example()
Dim dest_wbk As Workbook
Dim dest_ws As Worksheet
Dim source_wbk As Workbook
Dim source_ws As Worksheet
Set dest_wbk = ThisWorkbook
Set dest_ws = dest_wbk.ActiveSheet
sourcefilename = Range("Z1")
UserForm1.Show
Set source_wbk = ActiveWorkbook
Set source_ws = source_wbk.ActiveSheet
sourcelastrow = source_ws.Cells(Rows.Count, 2).End(xlUp).Row
Set lookuprange = source_ws.Range("A2:E" & sourcelastrow)
dest_lastrow = dest_ws.Cells(Rows.Count, 4).End(xlUp).Row
For i = 2 To des_lastrow
ID = dest_ws.Range("D" & i)
dest_ws.Range("K" & i) = Application.VLookup(ID, lookuprange, 3, False)
dest_ws.Range("L" & i) = Application.VLookup(ID, lookuprange, 4, False)
Next i
source_wbk.Close
End Sub
'Below in the code in the userform
Private Sub ListBox1_Click()
Sheets(ListBox1.Value).Activate
Unload Me
End Sub
Private Sub UserForm_Initialize()
Dim sh As Worksheet
strfile = ("C:\Documents\" & sourcefilename)
Set wbk = Workbooks.Open(strfile, ReadOnly:=True)
For Each sh In wbk.Sheets
ListBox1.AddItem sh.Name
Next sh
End Sub
You need to change your two variables dest_wbk and dest_ws to something like
In case your destination Workbook is already open
'Change Workbook2.xls to whatever the file is (assuming it is open already)
Set dest_wbk = Workbooks("Workbook2.xls")
'Change SheetName to whatever the sheet name is inside dest_wbk
Set dest_ws = dest_wbk.Sheets("SheetName")
Otherwise, you need to open the workbook
'Change Workbook2.xls to whatever the file is
Set dest_wbk = Workbooks.Open("Workbook2.xls")
'Change SheetName to whatever the sheet name is inside dest_wbk
Set dest_ws = dest_wbk.Sheets("SheetName")
It is up to you, to get those values (Workbook name and Sheet name) from the UserForm, which I believe it shouldn't be a problem for you.

Copy cells from a Worksheet to another Worksheet (from different Workbooks and first empty cell)

I am trying to copy the content from a user opened worksheet to another worksheet from another Workbook. The code below do works, but it doesnt select the first empty cell from the WS_REL sheet, and overwrite all the data contained. So far, I have this:
Sub Importar_Dados()
Dim vTemp As Variant
Dim WB_TOA As Workbook, WB_REL As Workbook
Dim WS_TOA As Worksheet, WS_REL As Worksheet
Set WB_REL = ActiveWorkbook
Set WS_REL = WB_REL.Sheets("Planilha2")
vTemp = Application.GetOpenFilename("Excel-files,*.xlsx", _
1, "Selecione o relatório gerado pelo TOA", , False)
If TypeName(vTemp) = "Boolean" Then Exit Sub
Workbooks.Open vTemp
Set WB_TOA = Workbooks.Open(vTemp)
Set WS_TOA = WB_TOA.Sheets("Page 1")
WS_TOA.Cells.Copy WS_REL.Cells
End Sub
Thank you!
First, you dont need to open the other workbook twice. Remove the line
Workbooks.Open vTemp
Then, to append without overwriting, you need to find the last non-empty cell in your destination sheet. Try it like (for example):
WS_TOA.usedRange.Copy WS_REL.Range("A999999").End(xlUp).Offset(1)
If you dont have a column that is sure to have data in all rows, use this:
WS_TOA.usedRange.Copy WS_REL.Range("A" & WS_REL.Cells.Find("*", , , , xlByRows, xlPrevious).Row+1)
This finds you the first non-empty row.

merging variable amount of files under matching columns

I have 3 open Excel files which i have opened using this code;
Dim myWorkbooks As New Collection
Sub GetFile()
Dim fNameAndPath As Variant, i As Long, x As Variant
fNameAndPath = Application.GetOpenFilename("All Files (*.*), *.*", , "Select Files To Be Opened", , True)
If Not IsArray(fNameAndPath) Then
If fNameAndPath = False Then Exit Sub Else fNameAndPath = Array (fNameAndPath)
End If
For i = LBound(fNameAndPath) To UBound(fNameAndPath)
Set x = Workbooks.Open(fNameAndPath(i))
myWorkbooks.Add x
Next
End Sub
i merged all the Sheets i Need in one Workbook. There is a mastersheet called "KomKo" in this Workbook. And i have other Sheets which are "data (2)" , "data (3)" and "data(4)". These Sheets can be more then 4 so i might have Sheets called "data(11) " and so on. I would like to be able to copy Column C of all "data" Sheets and paste it to Column A of "KomKo" Sheet. i should be able to paste These values to the next empty value of that Column A.
How can i do this ?
So, after you have corrected your question, this code should do the desired work:
Dim masterSheet As Worksheet
Set masterSheet = Sheets("Komko")
'Variable to save the used Range of the master sheet
Dim usedRangeMaster As Integer
Dim ws As Worksheet
'loop through each worksheet in current workbook
For Each ws In Worksheets
'If sheetname contains "data" (UCase casts the Name to upper case letters)
If InStr(1, UCase(ws.Name), "DATA", vbTextCompare) > 0 Then
'calculate the used range of the master sheet
usedRangeMaster = masterSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
'Variable to save the used Range of the sub sheet
Dim usedRangeSub As Integer
'calculate the used range of the sub sheet
usedRangeSub = ws.UsedRange.SpecialCells(xlCellTypeLastCell).Row
'copy relevant range from the subsheet
ws.Range("C1:C" & usedRangeSub).Copy
'paste the copied range after the used range in column a
masterSheet.Range("A" & usedRangeMaster).PasteSpecial
End If
Next ws
Since you already have a collection containing the relevant workbooks, you can just loop through these and copy the relevant stuff into your main wb.
So define a variable for the master sheet(to be able to refer to it)
And one Variable inside the loop which holds the "subsheet":
Dim mastersheet As Workbook
Set mastersheet = ThisWorkbook 'Assuming the code is inside the master sheet
Dim wb As Workbook
For Each wb In myWorkbooks
'Copy stuff
'Example to get a value from the "subsheet"
mastersheet.Sheets("sheet1").Cells(1, 1).Value = wb.Sheets("sheet1").Cells(1, 1)
Next wb
Then inside the loop, copy column c for example and paste it into column a of the master sheet:
wb.Sheets("sheet1").Range("C1").EntireColumn.Copy
mastersheet.Sheets("sheet1").Range("A1").PasteSpecial

Excel copy/paste data based on tab names in multiple files

I have a (hopefully) easy situation. I'm seeking to automate this process with a VBA macro.
I have an Excel spreadsheet (let's call this data.xls) that has multiple tabs with the following names (this is just an example):
Sucralose
Cellulose
Dextrose
Each tab simply has a column of data in it.
I want to know if there is a simple way to copy all the tabs of data to another spreadsheet with specific formatting for further operations (let's call this reduction.xls) based on the tab naming.
For example:
I want to copy Column A of tab Sucrose, Dextrose, Cellulose FROM data.xls TO Column F of the same named tabs (already existing) in reduction.xls [Sucrose, Dextrose, Cellulose].
I'm looking for a "true/false" type statement where the column from each tab in data.xls will be pasted into reduction.xls assuming the same exact named tab exists, without any need for interaction from the user.
Code posted below has the following features:
It is prepared for easily handling an arbitrary number of tabs. You have to modify only 3 lines, as indicated: 1) The list of tab names, 2) the name of the source workbook, 3) the name of the target workbook.
It is "protected" against missing tabs in the target workbook.
The structure is likely self-explanatory (although this might be a subjective statement).
.
Sub copy_tab(ByVal wsName As String)
Dim wbnamesrc As String
Dim wbnametrg As String
wbnamesrc = "source.xlsm" ' Change this line
wbnametrg = "Book8" ' Change this line
Dim wbsrc As Workbook
Dim wbtrg As Workbook
Set wbsrc = Workbooks(wbnamesrc)
Set wbtrg = Workbooks(wbnametrg)
If (WorksheetExists(wsName, wbnametrg)) Then
Dim rngsrc As Range
Dim rngtrg As Range
Application.CutCopyMode = False
wbsrc.Worksheets(wsName).Range("A:A").Copy
wbtrg.Worksheets(wsName).Range("A:A").PasteSpecial
End If
End Sub
Sub copy_tabs()
Dim wslist As String
Dim sep As String
wslist = "Sucralose|Cellulose|Dextrose|Sheet1" ' Change this line
sep = "|"
Dim wsnames() As String
wsnames = Split(wslist, sep, -1, vbBinaryCompare)
Dim wsName As String
Dim wsnamev As Variant
For Each wsnamev In wsnames
wsName = CStr(wsnamev)
Call copy_tab(wsName)
Next wsnamev
End Sub
Public Function str_split(str, sep, n) As String
' From http://superuser.com/questions/483419/how-to-split-a-string-based-on-in-ms-excel
' splits on your choice of character and returns the nth element of the split list.
Dim V() As String
V = Split(str, sep)
str_split = V(n - 1)
End Function
' From http://stackoverflow.com/a/11414255/2707864
Public Function WorksheetExists(ByVal wsName As String, ByVal wbName As String) As Boolean
Dim ws As Worksheet
Dim ret As Boolean
ret = False
wsName = UCase(wsName)
For Each ws In Workbooks(wbName).Worksheets
If UCase(ws.Name) = wsName Then
ret = True
Exit For
End If
Next
WorksheetExists = ret
End Function
Personally I would create the VBA in a separate workbook that you can open and execute separately from the other 2 interacting workbooks.
Thus I defined three dimension. wbk = workbook with code in it. wbk1 = the source workbook where you will copy from. wbk2 - the destination workbook where you will paste to.
You will have to edit the file locations as well as the Ranges. Say if you only wanted A1:A100, provided it is the same number of rows each time. If not I suggest increasing the rows far past what you anticipate the row count will be so you make sure you don't miss any.
Go to a new workbook
Hold Alt and press F11 key
Click Insert -> Module
Paste the below code in the window and update file locations and copy/paste range as needed
Press Run Macro (green play button) or hit F5 with your cursor in the code
Sub DataTransfer()
Dim wbk, wbk1, wbk2 As Workbook
'Workbook with VBA in it.
Set wbk = ActiveWorkbook
'Define destination workbook
Set wbk1 = Workbooks.Open("C:\data.xls")
'Define Source workbook
Set wbk2 = Workbooks.Open("C:\reduction.xls")
Call wbk1.Worksheets("Sucralose").Range("A1:A100000").Copy
Call wbk2.Worksheets("Sucralose").Range("F1:F100000").PasteSpecial(xlPasteValues)
Application.CutCopyMode = False
Call wbk1.Worksheets("Cellulose").Range("A1:A100000").Copy
Call wbk2.Worksheets("Cellulose").Range("F1:F100000").PasteSpecial(xlPasteValues)
Application.CutCopyMode = False
Call wbk1.Worksheets("Dextrose").Range("A1:A100000").Copy
Call wbk2.Worksheets("Dextrose").Range("F1:F100000").PasteSpecial(xlPasteValues)
Application.CutCopyMode = False
End Sub

Insert Rows VBA

Right now I have a master excel workbook that employees use for data entry. Each of them downloads a copy to their desktops and then marks their progress on various entries by entering an "x" in a comlun next to the data they've finished. Each product has its own row with its respective data listed across that row. The master workbook is filled out throughout the quarter with new data for the products as it becomes available, which is currently updated on each individuals workbook by use of a macro that simply copies the range where the data is (see code below).
Sub GetDataFromClosedWorkbook()
'Created by XXXX 5/2/2014
Application.ScreenUpdating = False ' turn off the screen updating
Dim wb As Workbook
Set wb = Workbooks.Open("LOCATION OF FILE", True, True)
' open the source workbook, read only
With ThisWorkbook.Worksheets("1")
' read data from the source workbook: (Left of (=) is paste # destination, right of it is copy)
.Range("F8:K25").Value = wb.Worksheets("1").Range("F8:K25").Value
End With
With ThisWorkbook.Worksheets("2")
' read data from the source workbook: (Left of (=) is paste # destination, right of it is copy)
.Range("V5:Z359").Value = wb.Worksheets("2").Range("V5:Z359").Value
End With
wb.Close False ' close the source workbook without saving any changes
Set wb = Nothing ' free memory
Application.ScreenUpdating = True ' turn on the screen updating
End Sub
The problem I'm having is this: every once and a while, I'll need to add a new product, which adds a row on the master (this is opposed to adding data, which is just added across the row). Sometimes this row is at the end, sometimes it's in the middle. As you can see from the code below, my VBA currently can't handle this row change as it is just copy/pasting from a predefined range. Each users's workbook does not pick up on this change in row # and thus the data in the colums becomes associated with the wrong rows. Normally, you could just copy the entire sheet and problem solved. The issue I have is that each user needs to be able to record their own process in their own workbook next to their data. Is there a way to code this so that a new row on the master sheet will be accounted for and added to all the others without erasing/moving the marks made by each user? I've been trying to find a way to make it "insert" rows if they're new in the master, as this would preserve the data, but can't figure it out. Also, due to security on the server at work- linking workbooks, etc is not an option. Does anyone have any thoughts on this?
One way to approach this problem would be using the Scripting.Dictionary Object. You could create a dictionary for both the target and source identifiers and compare those. I suppose you don't really need the Key-Value pair to achieve this, but hopefully this gets you on the right track!
Sub Main()
Dim source As Worksheet
Dim target As Worksheet
Dim dictSource As Object
Dim dictTarget As Object
Dim rng As Range
Dim i As Integer
Dim j As Integer
Dim idSource As String
Dim idTarget As String
Dim offset As Integer
Set source = ThisWorkbook.Sheets(2)
Set target = ThisWorkbook.Sheets(1)
offset = 9 'My data starts at row 10, so the offset will be 9
Set rng = source.Range("A10:A" & source.Cells(source.Rows.Count, "A").End(xlUp).Row)
Set dictSource = CreateObject("Scripting.Dictionary")
For Each cell In rng
dictSource.Add Key:=cell.Value, Item:=cell.Row
Next
Set rng = target.Range("A10:A" & target.Cells(target.Rows.Count, "A").End(xlUp).Row)
Set dictTarget = CreateObject("Scripting.Dictionary")
For Each cell In rng
dictTarget.Add Key:=cell.Value, Item:=cell.Row
Next
i = 1
j = source.Range("A10:A" & source.Cells(source.Rows.Count, "A").End(xlUp).Row).Rows.Count
Do While i <= j
Retry:
idSource = source.Cells(i + offset, 1).Value
idTarget = target.Cells(i + offset, 1).Value
If Not (dictSource.Exists(idTarget)) And idTarget <> "" Then
'Delete unwanted rows
target.Cells(i + offset, 1).EntireRow.Delete
GoTo Retry
End If
If dictTarget.Exists(idSource) Then
'The identifier was found so we can update the values here...
dictTarget.Remove (idSource)
ElseIf idSource <> "" Then
'The identifier wasn't found so we can insert a row
target.Cells(i + offset, 1).EntireRow.Insert
'And you're ready to copy the values over
target.Cells(i + offset, 1).Value = idSource
End If
i = i + 1
Loop
Set dictSource = Nothing
Set dictTarget = Nothing
End Sub