copying first 3 columns from different worksheets to single files - vba

I have a bunch of datasets with always the same worksheets.
Now I want to make a different file for each worksheet. I found some code that does just that: http://www.extendoffice.com/documents/excel/628-excel-split-workbook.html#kutools
However, I also only want the first three columns of those worksheets and preferably always starting from row 2.
Could somebody point me in the right direction. E.g. on how to change the code I posted.

Try below code :
Sub Splitbook()
Application.ScreenUpdating = False
Dim myPath As String
Dim rng As Range
Dim sht As Worksheet
Dim lastRow As Long
Dim wkb As Workbook
For Each sht In ThisWorkbook.Sheets
lastRow = sht.Range("A6500").End(xlUp).Row
If lastRow < 2 Then GoTo nextSht
Set rng = sht.Range("A2:C" & lastRow)
If Not rng Is Nothing Then
Set wkb = Workbooks.Add
rng.Copy wkb.Sheets(1).Range("A2")
myPath = filePath(sht.Name)
wkb.SaveAs Filename:=myPath
wkb.Close
Set wkb = Nothing
Set rng = Nothing
End If
nextSht:
Next
Application.ScreenUpdating = True
End Sub
Function filePath(worksheetname As String) As String
Dim fso As Object, MyFolder As String
Set fso = CreateObject("Scripting.FileSystemObject")
MyFolder = ThisWorkbook.Path & "\Reports"
If fso.FolderExists(MyFolder) = False Then
fso.CreateFolder (MyFolder)
End If
MyFolder = MyFolder & "\" & Format(Now(), "MMM_YYYY")
If fso.FolderExists(MyFolder) = False Then
fso.CreateFolder (MyFolder)
End If
filePath = MyFolder & "\" & worksheetname & Format(Now(), "DD-MM-YY hh.mm.ss") & ".xlsx"
Set fso = Nothing
End Function

Related

How to create new files from range

I would like to create new files (in the same folder) from sheet "lista strategiczna".D2 only if doesn't exist. Next offset one position down, and create next files etc. What I doing wrong?
Sub TworzenieZamowien()
Dim thisWb As Workbook
Dim nazwaPliku As String
Set thisWb = ActiveWorkbook
Dim aktywnaKomorka As Range
Set aktywnaKomorka = Sheets("lista strategiczna").Range("D2")
Dim FilePath As String
FilePath = Dir(ActiveWorkbook.Path, vbDirectory)
Do Until aktywnaKomorka = ""
nazwaPliku = thisWb.Path & "\Zamówienie " & aktywnaKomorka & ".xls"
If FilePath <> nazwaPliku Then
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=nazwaPliku
ActiveWorkbook.Close savechanges:=False
aktywnaKomorka.Offset(1, 0).Select
Else
aktywnaKomorka.Offset(1, 0).Select
End If
Loop
End Sub
I would set your range at the start, use a For loop and do away with selecting things (rarely a good idea). Your current code doesn't change aktywnaKomorka(it remains D2), you just activate the next cell below but your loop does not reference the active cell.
Sub TworzenieZamowien()
Dim thisWb As Workbook
Dim nazwaPliku As String
Set thisWb = ActiveWorkbook
Dim aktywnaKomorka As Range
With Sheets("lista strategiczna")
Set aktywnaKomorka = .Range("D2", .Range("D" & Rows.Count).End(xlUp))
End With
Dim FilePath As String, r As Range
FilePath = Dir(ActiveWorkbook.Path, vbDirectory)
For Each r In aktywnaKomorka
If r <> vbNullString Then
nazwaPliku = thisWb.Path & "\Zamówienie " & r & ".xls"
If FilePath <> nazwaPliku Then
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=nazwaPliku
ActiveWorkbook.Close savechanges:=False
End If
End If
Loop
End Sub
If you wanted to persist with your Do loop rather than Select add this line
set aktywnaKomorka=aktywnaKomorka.Offset(1, 0)

Copy data from multiple workbook to one workbook after using Autofilter

I am trying to copy data from multiple WB to one WB after using filter. I am able to select the copy range but I don't know how to paste them to the destination WB without making the data overwritten.
I am sorry for the format of my code. I do not know how to fix it when I post it here.
Here is my code:
Option Explicit
Const FOLDER_PATH = "D:\Programming\VBA\Linh\CARD DELIVERY\New folder\" 'REMEMBER END BACKSLASH
Sub ImportWorksheets()
'=============================================
'Process all Excel files in specified folder
'=============================================
Dim sFile As String 'file to process
Dim wsTarget As Worksheet
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim rowTarget As Long 'output row
Dim rowCount As Long
rowTarget = 2
'check the folder exists
If Not FileFolderExists(FOLDER_PATH) Then
MsgBox "Specified folder does not exist, exiting!"
Exit Sub
End If
'reset application settings in event of error
On Error GoTo errHandler
Application.ScreenUpdating = False
'set up the target worksheet
Set wsTarget = Sheets("Sheet1")
'loop through the Excel files in the folder
sFile = Dir(FOLDER_PATH & "*.xls*")
Do Until sFile = ""
'open the source file and set the source worksheet - ASSUMED WORKSHEET(1)
Set wbSource = Workbooks.Open(FOLDER_PATH & sFile)
Set wsSource = wbSource.Worksheets(1) 'EDIT IF NECESSARY
wsSource.Range("A2", Range("P" & Rows.Count).End(xlUp)).AutoFilter Field:=12, Criteria1:="Phát thành công"
wsSource.Range("I2", Range("I" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy
rowCount = wsSource.Range("I2", Range("I" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Cells.Count
'import the data
With wsTarget
End With
'close the source workbook, increment the output row and get the next file
wbSource.Close SaveChanges:=False
rowTarget = rowTarget + 1
sFile = Dir()
Loop
errHandler:
On Error Resume Next
Application.ScreenUpdating = True
'tidy up
Set wsSource = Nothing
Set wbSource = Nothing
Set wsTarget = Nothing
End Sub
Private Function FileFolderExists(strPath As String) As Boolean
If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
End Function
just add:
'import the data
wsTarget
.cells(.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial
End With
to keep pasting filtered data in wsTarget column A from row 2 downwards

How can I copy Excel sheets based on their name using VBA?

The background:
I have a directory containing multiple workbooks.
Each workbook contains multiple sheets, both hidden and visible.
I would like to copy one particular sheet from each workbook into an existing master workbook.
The problem:
At the moment, my code copies the first sheet in each source workbook.
I require the code to copy only the sheet called "[current month] Summary", which is most often not the first sheet in the source workbooks.
Because the [current month] will change, it needs to copy the sheet where the last seven letters of the name are "Summary".
My code as it stands:
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFilename As String
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Application.EnableEvents = False
Application.ScreenUpdating = False
MyPath = InputBox("Please copy and paste the path to the folder containing the source documents")
Set wbDst = ActiveWorkbook
strFilename = Dir(MyPath & "\*.xls", vbNormal)
If Len(strFilename) = 0 Then Exit Sub
Do Until strFilename = ""
Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename)
Set wsSrc = wbSrc.Worksheets(1)
wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)
wbSrc.Close False
strFilename = Dir()
Loop
Replace this line
Set wsSrc = wbSrc.Worksheets(1)
With
Set wsSrc = wbSrc.Worksheets("[current month] Summary")
Edit:
Replace your current Do Until Code with the below one :)
Do Until strFilename = ""
Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename)
For Each ws In wbSrc.Worksheets
If InStr(1, ws.Name, "summary", vbTextCompare) Then
Set wsSrc = ws
End If
Next ws
wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)
wbSrc.Close False
strFilename = Dir()
Loop
Following code will get the current month and after checking the name in workbooks will give you the desired result:
Dim currMonth As String
currMonth = MonthName(Month(Now))
Do Until strFilename = ""
Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename)
For Each ws In wbSrc.Worksheets
If ws.Name = currMonth & "Summary" Then
Debug.Print ws.Name
Set wsSrc = ws
wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)
Exit For
End If
Next
wbSrc.Close False
strFilename = Dir()
Loop

Excel VBA: select one row down in a loop

I have a source folder that contains many xls files. I want to create a master file - collect all information into one database from all files in the given source.
The following code creates 2 columns in master file and enters 2 values from the given source file (one file):
Sub getData()
Dim XL As Excel.Application
Dim WBK As Excel.Workbook
Dim scrFile As String
Dim myPath As String
myPath = ThisWorkbook.path & "\db\" 'The source folder
scrFile = myPath & "1.xlsx" 'Select first file
' Sheet name in the master file is "Sh"
ThisWorkbook.Sheets("Sh").Range("A1").Value = "Column 1"
ThisWorkbook.Sheets("Sh").Range("B1").Value = "Column 2"
Set XL = CreateObject("Excel.Application")
Set WBK = XL.Workbooks.Open(scrFile)
ThisWorkbook.Sheets("Sh").Range("A2").Value = WBK.ActiveSheet.Range("A10").Value
ThisWorkbook.Sheets("Sh").Range("B2").Value = WBK.ActiveSheet.Range("C5").Value
WBK.Close False
Set XL = Nothing
Application.ScreenUpdating = True
End Sub
Now I want to loop through all files and save the values from cells "A10" and "C5" from each file in one database, so the loop should select the next row to save new values.
I have an idea how to loop through all files, but don't know how to switch to the next row:
scrFile = Dir(myPath & "*.xlsx")
Do While scrFile <> ""
Set XL = CreateObject("Excel.Application")
Set WBK = XL.Workbooks.Open(scrFile)
' Here should be the code to save the values of A10 and C5 of the given file
'in the loop in next available row of the master file.
WBK.Close False
Set XL = Nothing
scrFile = Dir
Loop
Any help will be highly appreciated! :)
For simplicity, just use a counter:
scrFile = Dir(myPath & "*.xlsx")
n = 1 ' skip the first row with headers
Do While scrFile <> ""
n = n + 1
Set XL = CreateObject("Excel.Application")
Set WBK = XL.Workbooks.Open(scrFile)
' save the values of A10 and C5 of the given file in the next row
ThisWorkbook.Sheets("Sh").Range("A" & n).Value = WBK.ActiveSheet.Range("A10").Value
ThisWorkbook.Sheets("Sh").Range("B" & n).Value = WBK.ActiveSheet.Range("C5").Value
WBK.Close False
Set XL = Nothing
scrFile = Dir
Loop
msgbox n & " files imported."
BTW, you don't need to start a second Excel instance (CreateObject("Excel.Application")) just to open a second workbook. This will slow down your code a lot. Just open, read and close it. Address your master workbook not by ThisWorkbook but assign a varible to it:
Dim masterWB As Excel.Workbook
set masterWB = ThisWorkbook
...
masterWB.Sheets("Sh").Range("A" & n).Value = WBK.ActiveSheet.Range("A10").Value
You need to recalculate last row in the loop wtih End() function.
Like this for range .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0)
Or to have an integer .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row
Give this a try :
Sub getData()
Application.ScreenUpdating = False
Dim XL As Excel.Application, _
WBK As Excel.Workbook, _
MS As Worksheet, _
scrFile As String, _
myPath As String
'Sheet name in the master file is "Sh"
Set MS = ThisWorkbook.Sheets("Sh")
'The source folder
myPath = ThisWorkbook.Path & "\db\"
MS.Range("A1").Value = "Column 1"
MS.Range("B1").Value = "Column 2"
Set XL = CreateObject("Excel.Application")
scrFile = Dir(myPath & "*.xlsx")
Do While scrFile <> ""
Set WBK = XL.Workbooks.Open(scrFile)
' Here should be the code to save the values of A10 and C5 of the given file
'in the loop in next available row of the master file.
With MS
.Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Value = WBK.ActiveSheet.Range("A10").Value
.Range("B" & .Rows.Count).End(xlUp).Offset(1, 0).Value = WBK.ActiveSheet.Range("C5").Value
End With
WBK.Close False
scrFile = Dir
Loop
XL.Quit
Set XL = Nothing
Set MS = Nothing
Set WBK = Nothing
Application.ScreenUpdating = True
End Sub
I actually have a code here that will loop through each file and deposit the code into your main file. You are also able to choose the directory of the target folder.
Sub GatherData()
Dim sFolder As String
Application.ScreenUpdating = True
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder..."
.Show
If .SelectedItems.Count > 0 Then
sFolder = .SelectedItems(1) & "\"
Else
Exit Sub
End If
End With
Call Consolidate(sFolder, ThisWorkbook)
End Sub
Private Sub Consolidate(sFolder As String, wbMaster As Workbook)
Dim wbTarget As Workbook
Dim objFso As Object
Dim objFiles As Object
Dim objSubFolder As Object
Dim objSubFolders As Object
Dim objFile As Object
Dim ary(3) As Variant
Dim lRow As Long
'Set Error Handling
On Error GoTo EarlyExit
'Create objects to enumerate files and folders
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFiles = objFso.GetFolder(strFolder).Files
Set objSubFolders = objFso.GetFolder(strFolder).subFolders
'Loop through each file in the folder
For Each objFile In objFiles
If InStr(1, objFile.Path, ".xls") > 0 Then
Set wbTarget = Workbooks.Open(objFile.Path)
With wbTarget.Worksheets(1)
ary(0) = .Range("B8") 'here you can change the cells you need the data from
ary(1) = .Range("B12")
ary(2) = .Range("B14")
End With
With wbMaster.Worksheets(1)
lRow = .Range("E" & .Rows.Count).End(xlUp).Offset(1, 0).Row 'here you can change the row the data is deposited in
.Range("E" & lRow & ":G" & lRow) = ary
End With
wbTarget.Close savechanges:=False
End If
Next objFile
'Request count of files in subfolders
For Each objSubFolder In objSubFolders
Consolidate objSubFolder.Path, wbMaster
Next objSubFolder
EarlyExit:
'Clean up
On Error Resume Next
Set objFile = Nothing
Set objFiles = Nothing
Set objFso = Nothing
On Error GoTo 0
End Sub

copying workbooks from current folder and also subfolders

This is part of the sub I found to copy all tabs in all workbooks in a directory to my current workbook, but how can I adjust it to scan all subfolders as well? Currently, it only copies from the folder I select and then stops.
Here's the full code with functions: http://www.vbaexpress.com/kb/getarticle.php?kb_id=829
Sub CombineFiles()
Dim path As String
Dim FileName As String
Dim LastCell As Range
Dim Wkb As Workbook
Dim WS As Worksheet
Dim ThisWB As String
ThisWB = ThisWorkbook.Name
Application.EnableEvents = False
Application.ScreenUpdating = False
path = GetDirectory
FileName = Dir(path & "\*.xls*", vbNormal)
Do Until FileName = ""
If FileName <> ThisWB Then
Set Wkb = Workbooks.Open(FileName:=path & "\" & FileName)
For Each WS In Wkb.Worksheets
Set LastCell = WS.Cells.SpecialCells(xlCellTypeLastCell)
If LastCell.Value = "" And LastCell.Address = Range("$A$1").Address Then
Else
WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
End If
Next WS
Wkb.Close False
End If
FileName = Dir()
Loop
Application.EnableEvents = True
Application.ScreenUpdating = True
Set Wkb = Nothing
Set LastCell = Nothing
End Sub
Using the code I posted in the linked question (untested)
Sub CombineFiles()
Dim path As String
Dim FileName As String
Dim LastCell As Range
Dim Wkb As Workbook
Dim WS As Worksheet
Dim ThisWB As String
Dim colFiles As New Collection, fPath
ThisWB = ThisWorkbook.path & "\" & ThisWorkbook.Name
Application.EnableEvents = False
Application.ScreenUpdating = False
path = GetDirectory
GetFiles path, "*.xls*", True, colFiles
For Each fPath In colFiles
If fPath <> ThisWB Then
Set Wkb = Workbooks.Open(FileName:=fPath)
For Each WS In Wkb.Worksheets
Set LastCell = WS.Cells.SpecialCells(xlCellTypeLastCell)
If LastCell.Value = "" And LastCell.Address = Range("$A$1").Address Then
Else
WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
End If
Next WS
Wkb.Close False
End If
Next fPath
Application.EnableEvents = True
Application.ScreenUpdating = True
Set Wkb = Nothing
Set LastCell = Nothing
End Sub
VBA macro that search for file in multiple subfolders