Migrating specific columns (almost 250) from one Excel workbook to another - vba

Migrating data from one workbook to other. In new workbook I want only specific columns (that are almost 250). As the data in Master file, is inconsistent and not in same range, so how can I extract those 250 columns? As, I am new to VBA, I have tried the code below, it's working but I have to write long code for all that 250 columns? Any help will be greatly appreciated.
Sub Data_Migration()
Dim y As Workbook
Dim x As Workbook
Dim ws As Worksheet
Dim sh As Worksheet
Dim rng As Range
Set y = ThisWorkbook
Application.ScreenUpdating = 0
Set x = Workbooks.Open("file path")
'Column Q from master file with worksheet name cba is copied in new workbook with sheet name abc and pasted in column D
Set ws = y.Sheets("abc")
Set sh = x.Sheets("cba")
Set rng = sh.Range("Q2:Q11443")
rng.Copy
y.Sheets("abc").Range("D1").PasteSpecial xlValues
Application.CutCopyMode = False
Set ws = y.Sheets("abc")
Set sh = x.Sheets("cba")
Set rng = sh.Range("Z2:Z11443")
rng.Copy
y.Sheets("abc").Range("E1").PasteSpecial xlValues
Application.CutCopyMode = False
Set ws = y.Sheets("abc")
Set sh = x.Sheets("cba")
Set rng = sh.Range("AI2:AI11443")
rng.Copy
y.Sheets("abc").Range("F1").PasteSpecial xlValues
Application.CutCopyMode = False
x.Close
End sub

Paste the following code into a standard code module (by default 'Module1' but you can name it to your liking).
Sub Main()
' 21 Mar 2017
Dim WsS As Worksheet ' S = Source
Dim WbT As Workbook, WsT As Worksheet ' T = Target
Dim Cs As Long, Ct As Long ' Column numbers: Source & Target
Dim Clms As Variant
Dim i As Integer ' index for Clms
Application.ScreenUpdating = False
On Error GoTo ErrExit
' Source is the first worksheet in the active workbook:
Set WsS = ActiveWorkbook.Worksheets("Haseev")
Set WbT = Workbooks.Add(xlWBATWorksheet)
Set WsT = WbT.Worksheets(1)
WsT.Name = "Extract 250" 'name the target sheet
Clms = Array(1, 4, 8, 13) ' list column numbers < 17
For i = 0 To UBound(Clms)
CopyColumn WsS, WsT, Clms(i), Ct
Next i
For Cs = 17 To Columns("CHU").Column Step 9
CopyColumn WsS, WsT, Cs, Ct
'''' If Ct > 10 Then Exit For
Next Cs
ErrExit:
Application.ScreenUpdating = True
End Sub
Understand the code:-
Make the currently active workbook the "Source", meaning you must look at the workbook from which you are about to copy data. The code expects to find a worksheet by the name of "Haseev" in this workbook. Change the name in the code or change that entire line of code to
Set WsS = ActiveWorkbook.Worksheets(1)
That specifies the first worksheet in the workbook which makes good sense because a large workbook like yours isn't likely to have too many sheets.
The code will create a new workbook with a single sheet in it. It will name that sheet "Extract 250". Change the name in the code to something you prefer.
Next, the code will copy selected columns to the new workbook.
Clms = Array(1, 4, 8, 13)
You can specify which columns you want to copy - as many as you need, numbers separated by commas. If you don't want any, just leave the specification blank, like Clms = Array()
In the next loop every 9th column is copied, starting from column 17 to column "CHU". You can modify the "CHU". The line
'''' If Ct > 10 Then Exit For
is a leftover from my testing. You may like to use it for the same purpose. Remove the apostrophes which disable the code and the loop will stop copying after 10 columns have been copied to the new workbook.
You may notice that the above code doesn't contain any copy or paste. Instead, it calls the next sub which you should paste below the Main procedure you already copied above.
Private Sub CopyColumn(WsS As Worksheet, _
WsT As Worksheet, _
ByVal Cs As Long, _
Ct As Long)
' 21 Mar 2017
' Ct is a return Long
If Cs > 0 Then ' column number must be > 0
Ct = Ct + 1
WsS.Columns(Cs).Copy Destination:=WsT.Columns(Ct)
End If
End Sub
Basically, the Main procedure just manages the 250 plus times this sub will be called.
The output workbook will have a generic name given by Excel, like "Sheet1". You can save it under any name you wish or close it and make a new one next time you wish to look at it.

You need a For .. Next loop. Basically,
Dim C As Long
For C = 1 to 250
' enter repetitive code here
Next C
If C is your column number, you can use C as the column number instead of "A", "B", "C". Excel isn't very good at letters. It converts the A you type into 1, B to 2, C to 3 etc - up to 250.
However, it seems that you don't need consecutive columns. So, you create an array of the numbers you need.
Dim Arr As Variant
Arr = Array(1, 12, 16, 25, 32) ' list all your 250 columns.
Now, Arr(0) = 1, Arr(1) = 12, Arr(2) = 16 etc.
and you construct your loop to refer to these numbers.
Dim n As Integer
For n = 0 to Ubound(Arr) ' that the number of elements in Arr
C = Arr(n)
Debug.Print C ' this will write C in the immediate window
Next n
In this structure you can use C as the column number, like,
Set Rng = Sh.Range(Cells(3, C), Cells(11443, C))
Cells(3, C) specifies A3, if C = 1
PS Just occurred to me that you might need this, too:-
Range("ZH2").Column should return the column number for column "ZH"

Related

Deleting rows based on criteria

I have a little code so I can move specific rows to a specific sheet which is structured as follows:
sheet 1 (contains all data)
sheet 2 (the destination sheet of rows to move)
So basically the code looks for a keyword on a specific column, and copies all rows that meet that criteria on the specified column from sheet 1 to sheet 2, it does that like a charm. The problem I have is because of data organization, I need to delete the rows once they have been copied, I tried using the .cut target instead of .copy target, and it works too, but it takes extremely long (about 1+ min), and it looks like that whole time is frozen as it doesn't let you select anything.
Any suggestions to accomplish this more efficiently? I am learning VBA, so please bear with me.
Sub Copydatatoothersheet()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("Sheet1")
Set Target = ActiveWorkbook.Worksheets("Sheet2")
j = 3 ' Start copying to row 3 in target sheet
Application.ScreenUpdating = False
For Each c In Source.Range("BB:BB")
If c = "UNPAID" Then
'THIS IS THE LINE WHERE I REPLACE COPY WITH CUT
Source.Rows(c.Row).Copy Target.Rows(j)
j = j + 1
End If
Next c
Application.ScreenUpdating = True
End Sub
Try store the desired ranges in a variable then delete the entire rows of that stored range
Sub Copydatatoothersheet()
Dim c As Range
Dim j As Integer
Dim source As Worksheet
Dim target As Worksheet
Dim oRange As Range
' Change worksheet designations as needed
Set source = ActiveWorkbook.Worksheets("Sheet1")
Set target = ActiveWorkbook.Worksheets("Sheet2")
j = 3 ' Start copying to row 3 in target sheet
Application.ScreenUpdating = False
For Each c In source.Range("BB:BB")
If c = "UNPAID" Then
'THIS IS THE LINE WHERE I REPLACE COPY WITH CUT
source.Rows(c.Row).Copy target.Rows(j)
If oRange Is Nothing Then Set oRange = c Else Set oRange =
Union(oRange, c)
j = j + 1
End If
Next c
If Not oRange Is Nothing Then oRange.EntireRow.Delete
Application.ScreenUpdating = True
End Sub
Use AutoFilter
Sub foo()
Dim Source As Worksheet
Dim Target As Worksheet
' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("Sheet1")
Set Target = ActiveWorkbook.Worksheets("Sheet2")
With Source
With .Range("BB:BB" & .Cells(.Rows.Count, "BB").End(xlUp).Row) 'reference its column BB cells from row 1 (header) down to last not empty one
.AutoFilter field:=1, Criteria1:= "UNPAID"' filter referenced cells on 1st column with "UNPAID" content
If Application.WorksheetFunction.Subtotal(103, .Columns(1)) > 1 Then
With .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
Intersect(.EntireRow, .Parent.UsedRange), .Parent.UsedRange).Copy Destination:=Target.Range("A1") ' if any filtered cell other than the header then copy their entire rows and paste to 'Target' sheet starting from its cell A1
.EntireRow.Delete ‘finally, delete these rows
End With
End If
End With
.AutoFilterMode = False
End With
End Sub
You may also add the ScreenUpdating toggling

Write on the next available cell of a given column

I have a somewhat simple macro that I have made but I am rusty as I have not coded in a few years. As simply as I can put it, I Have two different Workbooks. If the workbook I have open has a certain value (or no value), I want it to fill the other workbook("Test Template") with either "proposal or pre-proposal."
That has all been easy for me. But since the worksheet adds rows as we input data, I need it to fill those values in the next available row.
I will attach code but don't worry about the proposal stuff, I just need the range changed from a specific cell into the next available cell in the column. (if d28 is full, put in d29).
Public Sub foo()
Dim x As Workbook
Dim y As Workbook
'## Open both workbooks first:
Set x = ActiveWorkbook
Set y = Workbooks.Open("C:\Users\hmaggio\Desktop\Test Template.xlsx")
'copy Names from x(active):
x.Sheets("Sheet1").Range("C4").Copy
'paste to y worksheet(template):
y.Sheets("Sheet1").Range("B28").PasteSpecial
If x.Sheets("Sheet1").Range("C15") = "" Then
y.Sheets("Sheet1").Range("D28").Value = "proposal"
Else
y.Sheets("Sheet1").Range("D28").Value = "preproposal"
End If
First, you need a variable where you'll store the last used row number:
dim lngRows as long
lngRows = Cells(Rows.Count, "D").End(xlUp).Row
Then replace your lines of code where you have .Range("B28") with either .Cells(lngRows+1,2) or .Range("B"&lngRows)
The object Range offers a method called End that returns the last range on a certain direction.
Range("A1").End(xlDown) '<-- returns the last non-empty range going down from cell A1
Range("A1").End(xlUp) '<-- same, but going up
Range("A1").End(xlToRight) '<-- same, but going right
Range("A2").End(xlToLeft) '<-- same, but going left
In your case, hence, you can detect and use the last row of column B like this:
nextRow = y.Sheets("Sheet1").Range("B3").End(xlDown).Row + 1
More details:
The first Range of your column B is the header Range("B3")
You get the last filled range going down with .End(xlDown)
Specifically, you get the Row of that range
You add + 1 (cause you want the next available row
You store the row in the variable nextRow
... that you can then use like this:
y.Sheets("Sheet1").Range("B" & nextRow ).PasteSpecial
Try this
Public Sub foo()
Dim x As Workbook
Dim y As Workbook
Dim fromWs As Worksheet
Dim toWs As Worksheet
Dim Target As Range
'## Open both workbooks first:
Set x = ActiveWorkbook
Set y = Workbooks.Open("C:\Users\hmaggio\Desktop\Test Template.xlsx")
Set fromWs = x.Sheets("Sheet1")
Set toWs = y.Sheets("Sheet1")
With fromWs
Set Target = toWs.Range("b" & Rows.Count).End(xlUp)(2) '<~~next row Column B cell
Target = .Range("c4") 'Column B
If .Range("c15") = "" Then
Target.Offset(, 2) = "proposal" 'Column D
Else
Target.Offset(, 2) = "preproposal"
End If
End With
End Sub

Excel VBA: Insert N number of Sheets based on cell value

I'm new in Excel VBA. I want to insert number of cells based on a cell value.
I have sheet1, i want to use b4 as a reference as to the number of sheets (which is a template) to be inserted.
Example, if value of b4 = 4, I'd like to copy the template sheet 4 times.
How do i do that in vba?
THANKS. :)
No magic, create them one by one in a loop, place each new one at the end. Edit: You want also to rename them 1, 2, 3, 4,.. so:
Sub CreateSheets()
Dim i As Long
With ThisWorkbook.Sheets
For i = 1 To Sheet1.Range("B4").Value2
.Item("Template").Copy After:=.Item(.Count)
.Item(.Count).Name = i
Next
End With
End Sub
Or something like this...
Sub CopyTemplate()
Dim ws As Worksheet, wsTemplate As Worksheet
Dim n As Integer, i As Long
Application.ScreenUpdating = False
Set ws = Sheets("Sheet1")
Set wsTemplate = Sheets("Template") 'Where Template is the name of Template Sheet, change it as required.
n = ws.Range("B4").Value
If n > 0 Then
For i = 1 To n
wsTemplate.Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = i
Next i
End If
Application.ScreenUpdating = True
End Sub
Something like this should work:
Sub copySheets()
Dim i As integer
Dim n As integer 'the amount of sheets
n = Cells(4, 2).Value 'b4
For i = 2 To n
If ActiveWorkbooks.Worksheets.Count < n Then 'Makes sure the sheets exists
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
End If
ws1.Copy ThisWorkbook.Sheets(Sheets.Count) 'copy data
Next i
End Sub

If Cells in column A equal cells in column A on other workbook copy that row

I've been stuck on this for ages, it seems relatively simple in my head but I cant get it to work.. So what I need is say if I have a cell in workbook1 equals Bob, if that cell is in the same column in another workbook, copy that row..
So example.. if Bob in column A workbook1 is found in Column A workbook2 copy whatever is in the column b,c,d,e on bobs row into workbook2..
I could get it to work for singular ones easily but its for 500+ entries.
I've tried using arrays here is what I have got so far (the code is currently in a button on workbook1)
Dim owb As Workbook
Dim test1(500) As String, test2(500) As String, test3(500) As String, test4(500) As String
With Application
.DisplayAlerts = False
.ScreenUpdating = False
.EnableEvents = False
End With
fpath = "\Work\new location\test subject.xlsx" 'file location
Set owb = Application.Workbooks.Open(fpath) 'open file
For i = 1 To 500 'for each I
test1(i) = ThisWorkbook.Worksheets("Allsites").Cells(i, 1).Value
test2(i) = ThisWorkbook.Worksheets("Allsites").Cells(i, 8).Value
test3(i) = owb.Worksheets("Sheet2").Cells(i, 1).Value
test4(i) = owb.Worksheets("Sheet2").Cells(i, 2).Value 'declare locations
If test3(i) = test1(i) Then
test2(i) = test4(i)
End If
Next
In the example above, you're checking for a match in the exact cell (eg the value in A5 is the same as the one in A5), so I've assumed the same in the code below.
Dim sourceSheet As Worksheet
Dim destinationSheet As Worksheet
Dim columnNumber As Integer
Set sourceSheet = Worksheets("Sheet3")
Set destinationSheet = Worksheets("Sheet2")
Dim sourceArr() As Variant
Dim destArr() As Variant
sourceArr = sourceSheet.Range("A1:E500")
destArr = destinationSheet.Range("A1:E500")
For i = 1 To 500 'for each I
If destArr(i, 1) = sourceArr(i, 1) Then
For columnNumber = 2 To 5
destArr(i, columnNumber) = sourceArr(i, columnNumber)
Next
End If
Next
destinationSheet.Range("A1:A500").Value = destArr
There is a nice article about transferring data between arrays and worksheet ranges at http://www.cpearson.com/excel/ArraysAndRanges.aspx. Working with an array and writing the whole array in one go will be quicker than writing the value of each cell individually.
Update:
If the data can be in any row on the source spreadsheet, you can use Find to search for it. This may be quite a bit slower:
For i = 1 To 500 'for each I
Dim found As Range
Set found = searchRange.Find(destArr(i, 1), LookIn:=xlValues, lookat:=xlWhole)
If Not found Is Nothing Then
For columnNumber = 2 To 5
destArr(i, columnNumber) = found.Offset(0, columnNumber - 1)
Next
End If
Next
You may want to consider using a VLookup function in the worksheet rather than using VBA.

loop through columns on worksheet, copy data to new worksheet in new workbook - im stuck

I have a workbook that consists of several worksheets all with the same column headers. The rows in each worksheet identify an employee task and other task information. Columns starting at AB - BE containing an employee’s title as the column name along with email address in the row if they assisted in that task. Some of the rows are in a particular column if that employee roll has not touched that task.
I am looking to do the following.
Create a new workbook for new worksheets to be added
Loop through AB:BE and create a new worksheet in the new workbook with the column header name as the worksheet name
Filter this column (example: AB) to only include data that is in this list and not blanks
Copy this column data (AB as an example) into this new worksheet
Also copy Rows B, F, H from original worksheet to this new worksheet
Clear the filters on the main worksheet
Loop to next column (example AC) , repeat with creation of new worksheet in the workbook
I have done this in the past with rows just fine – I am having issues conceptually thinking about how this should work.
Does anyone have any examples? I have searched google for a few days and can get close in some areas however it does not scale well / loop on the data well.
Note: This could also be done with an Advanced Filter. That allows a filtered range to be copied to a new sheet.
I'm not sure I'm entirely understanding the sheet layout, but here's some basic code to create a new sheet for each column AB:BE, then for each row in column AB that is not empty, copy that cell value, along with the value in columns B, F, and H to a row in that new worksheet. Repeating then for columns AC:BE.
Sub CopyRoles()
Dim nSheet As Integer
Dim nTasks As Integer
Dim nSourceRow As Long
Dim nDestRow As Long
Dim wkb As Workbook
Dim wksSource As Worksheet
Dim wksDest As Worksheet
Set wksSource = ActiveSheet
Set wkb = Workbooks.Add
For nTasks = wksSource.Range("AB1").Column To wksSource.Range("BE1").Column
nSheet = nTasks - wksSource.Range("AB1").Column + 1
With wkb.Sheets
If .Count < nSheet Then ' Checks if sheet count on wkb exceeded
Set wksDest = .Add(after:=.Item(.Count), Type:=xlWorksheet)
Else
Set wksDest = .Item(nSheet) ' Keeps from having empty sheets
End If
wksDest.Name = wksSource.Cells(1, nTasks)
End With
With wksSource
wksDest.Cells(1, 1) = "E-mail address" ' Add header row to sheet
wksDest.Cells(1, 2) = .Cells(.UsedRange.Row, 2) ' Col B
wksDest.Cells(1, 3) = .Cells(.UsedRange.Row, 6) ' Col F
wksDest.Cells(1, 4) = .Cells(.UsedRange.Row, 8) ' Col H
nDestRow = 2
For nSourceRow = .UsedRange.Row + 1 To .UsedRange.Rows.Count
If .Cells(nSourceRow, nTasks).Value <> "" Then
wksDest.Cells(nDestRow, 1).FormulaR1C1 = _
.Cells(nSourceRow, nTasks).Value
wksDest.Cells(nDestRow, 2).FormulaR1C1 = _
.Range("B" & nSourceRow).Value
wksDest.Cells(nDestRow, 3).FormulaR1C1 = _
.Range("F" & nSourceRow).Value
wksDest.Cells(nDestRow, 4).FormulaR1C1 = _
.Range("H" & nSourceRow).Value
nDestRow = nDestRow + 1
End If
Next nSourceRow
End With
Next nTasks
wkb.SaveAs
End Sub