I'm creating a script to import data from a series of Workbooks in a declared folder.
The Workbook may contain multiple sheets as dictated by the values on the "DD Meeting" tab, whereby if the cell value begins with "Code_", there will be no sheet to import from.
I'm trying to create a script that looks for a sheet name based on these values, copies the data, then looks for the next sheet to resume the copy job.
I can copy from the first sheet fine, however the script then has trouble searching for the next sheet name using an activecell instead of the declaring a specific cell (I need to offset hence can't name the cell).
This works:
Set wsData = wb.Sheets(Worksheets("DD Meeting").Range("D6").Value)
This doesnt:
Set wsData = wb.Sheets(Worksheets("DD Meeting").ActiveCell.Value)
Any help is appreciated, thanks.
Sub ImportInfo()
Dim sPath As String 'path of folder containing info
Dim sFileName As String '
Dim wsSummary As Worksheet 'worksheet to paste data to in this workbook
Dim wsData As Worksheet 'sheet with data to copy
Dim wb As Workbook 'workbooks to loop thorugh
Dim nr As Long 'next row to add the data
'Get the worksheet to add the info to
Set wsSummary = ThisWorkbook.Worksheets("Sheet1")
'first row is 2
nr = 2
sPath = "C:\Users\sthorley\Downloads\Test\" '[COLOR=#ff0000][B]Change as required[/B][/COLOR]
sFileName = Dir(sPath & "*.xlsm")
Do While sFileName <> ""
'open workbook
Set wb = Workbooks.Open(Filename:=sPath & sFileName, ReadOnly:=True)
wb.Sheets(Worksheets("DD Meeting").Range("D6").Value).Activate
'get the sheet to copy from
Set wsData = wb.Sheets(Worksheets("DD Meeting").Range("D6").Value)
Worksheets("DD Meeting").Select
Worksheets("DD Meeting").Range("D6").Select
'get the data
Do While ActiveCell.Value <> "*Code*"
wsSummary.Range("A" & nr).Value = wsData.Range("B5").Value
wsSummary.Range("B" & nr).Value = wsData.Range("B3").Value
wsSummary.Range("C" & nr).Value = sFileName
wsData.Activate
wsData.Range("A5").Select
' Summary Key Points
wsData.Cells.Find(What:="Summary/Key points", After:=ActiveCell, LookIn:= _
xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext _
, MatchCase:=False, SearchFormat:=False).Activate
wsSummary.Range("D" & nr).Value = ActiveCell.Offset(2).Value
'get next row
nr = nr + 1
Worksheets("DD Meeting").Select
ActiveCell.Offset(1).Select
'get the sheet to copy from
Set wsData = Nothing
Set wsData = wb.Sheets(Worksheets("DD Meeting").ActiveCell.Value)
Loop
'close the workbook
wb.Close savechanges:=False
'get next workbook name
sFileName = Dir
Loop
End Sub
Related
I have a challenge on achieving the below project, kindly please assist:
I have four source workbooks with names(GK,SK,RJ and TB).
Each workbook(GK,SK,RJ and TB) have three worksheets with the same names(products, channels, and sales).
I have destination workbook called consolidated workbook with the same worksheets names(products, channels, and sales) like those of the four source workbooks.
All workbooks(source + destinations) are in the same folder.
Iam requesting VBA code that will copy data from each worksheet of all the four source workbooks and transfer/paste the data to worksheets in consolidated workbook based on the rows that were not previously copied from the last copy event.
Currently I have the below code but whenever I ran it copies everything from worksheets on the source workbooks and paste to worksheets in consolidated workbook which result to duplicated data.
All the source workbook have worksheets with the "DATE" as a first column in each worksheet table column.
Destination workbook also have the same worksheet names and the same columns structure on each worksheet are the same as of those source worksheet.
Kindly advise what should I amend so that the code will that will copy data from each worksheet of all the four source workbooks and transfer/paste the data to worksheets in consolidated workbook based on the rows that were not previously copied from the last copy event.
Sub Copy_From_All_Workbooks()
Dim wb As String, i As Long, sh As Worksheet
Application.ScreenUpdating = False
wb = Dir(ThisWorkbook.Path & "\*")
Do Until wb = ""
If wb <> ThisWorkbook.Name Then
Workbooks.Open ThisWorkbook.Path & "\" & wb
For Each sh In Workbooks(wb).Worksheets
sh.UsedRange.Offset(1).Copy '<---- Assumes 1 header row
ThisWorkbook.Sheets(sh.Name).Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Next sh
Workbooks(wb).Close False
End If
wb = Dir
Loop
Application.ScreenUpdating = True
End Sub
Kindly please see the amended code:
Sub Copy_From_All_Workbooks()
Dim wb As String, i As Long, sh As Worksheet, fndRng As Range,
start_of_copy_row As Long, end_of_copy_row As Long, range_to_copy As
Range
Application.ScreenUpdating = False
wb = Dir(ThisWorkbook.Path & "\*")
Do Until wb = ""
If wb <> ThisWorkbook.Name Then
Workbooks.Open ThisWorkbook.Path & "\" & wb
For Each sh In Workbooks(wb).Worksheets
On Error Resume Next
sh.UsedRange.Offset(1).Copy '<---- Assumes 1 header row
Set fndRng = sh.Range("A:A").Find(date_to_find,LookIn:=xlValues,
searchdirection:=xlPrevious)
If Not fndRng Is Nothing Then
start_of_copy_row = fndRng.Row + 1
Else
start_of_copy_row = 2 ' assuming row 1 has a header you want to ignore
End If
end_of_copy_row = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
Set range_to_copy = Range(start_of_copy_row & ":" & end_of_copy_row)
latest_date_loaded = Application.WorksheetFunction.Max(ThisWorkbook.Sheets(sh.Name).Range("A:A"))
ThisWorkbook.Sheets(sh.Name).Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
On Error GoTo 0
Application.CutCopyMode = False
Next sh
Workbooks(wb).Close False
End If
wb = Dir
Loop
Application.ScreenUpdating = True
End Sub
Kindly please see how consolidated workbook appear(the sheet names and column format are exactly the same as of the source workbooks.)
CONSOLIDATED WORKBOOK
The following line can be used to find the latest date loaded on your consolidated sheet:
latest_date_loaded = Application.WorksheetFunction.Max(ThisWorkbook.Sheets(sh.Name).Range("A:A"))
The following lines can be used on a worksheet (sh) to create a range (for copying) that starts after the latest_date_loaded down to the bottom of the table. You'll therefore need to ensure this is in date order.
Dim fndRng As Range, start_of_copy_row As Long, end_of_copy_row As Long, range_to_copy As Range
date_to_find = latest_date_loaded
Set fndRng = sh.Range("A:A").Find(date_to_find, LookIn:=xlValues, searchdirection:=xlPrevious)
If Not fndRng Is Nothing Then
start_of_copy_row = fndRng.Row + 1
Else
start_of_copy_row = 2 ' assuming row 1 has a header you want to ignore
End If
end_of_copy_row = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
Set range_to_copy = Range(start_of_copy_row & ":" & end_of_copy_row)
EDIT
Here is a rework of your code, using some of the lines/ideas I've mentioned above.
Sub Copy_From_All_Workbooks()
'declarations
Dim wb As String, i As Long, sh As Worksheet, fndRng As Range, _
start_of_copy_row As Long, end_of_copy_row As Long, range_to_copy As _
Range, latest_date_loaded As Date, consolidated_wb As Workbook
'turn off screen updating for user experience
'Application.ScreenUpdating = False
'set a reference to the consolidated workbook
Set consolidated_wb = ThisWorkbook
'read parent folder of consolidated workbook
wb = Dir(consolidated_wb.Path & "\*")
'perform this loop until no more files
Do Until wb = ""
'make sure it doesn't try to open consolidated workbook (again)
If wb <> consolidated_wb.Name Then
'open found source workbook
Workbooks.Open consolidated_wb.Path & "\" & wb
'cycle through each sheet (sh)
For Each sh In Workbooks(wb).Worksheets
'on that sheet, find the latest date already existing
latest_date_loaded = Application.WorksheetFunction.Max(consolidated_wb.Sheets(sh.Name).Range("A:A"))
'find the last occurence of that date in column A
Set fndRng = sh.Range("A:A").Find(latest_date_loaded, LookIn:=xlValues, _
searchdirection:=xlPrevious)
'if you find that date already then..
If Not fndRng Is Nothing Then
'set the top row to where you found it, plus one
start_of_copy_row = fndRng.Row + 1
Else
'otherwise, it's a new sheet, start on row two
start_of_copy_row = 2 ' assuming row 1 has a header you want to ignore
End If
'find the end of the table, using column A's contents
end_of_copy_row = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
'make sure there's something to copy
If end_of_copy_row >= start_of_copy_row Then
'create a reference to the block of cells to copy
Set range_to_copy = sh.Range(start_of_copy_row & ":" & end_of_copy_row)
'copy that range
range_to_copy.Copy
'paste them, values only
consolidated_wb.Sheets(sh.Name).Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
'clear copy markings from screen
Application.CutCopyMode = False
Else
'otherwise, do nothing here
End If
Next sh
'close the source workbook
Workbooks(wb).Close False
End If
'get next potential filename
wb = Dir
Loop
'turn back on screen updating
Application.ScreenUpdating = True
End Sub
Today with VBA I was trying to come with something that would modify several .xlsx files in a folder and then would copy and paste the data to another worksheet. In one of the steps, I am trying to select and delete specific columns from the other Excel file based on headers' names in VBA. The columns I would like to remove are all between the headers named "Unsubscribed" and "Webinar Question 1". The issue is that when it come to this part, it gives me an error 91:
With Worksheets("Sheet0").Range("A1:BB1")
Range(Worksheets("Sheet0").Range("A1:BB1").Find(What:="Unsubscribed", LookIn:=xlValues, MatchCase:=False).Offset(0, 1), _
Cells(Worksheets("Sheet0").Cells(Worksheets("Sheet0").Rows.Count, "A").End(xlUp).Row, _
Worksheets("Sheet0").Range("A1:BB1").Find(What:="Webinar Question 1", LookIn:=xlValues, MatchCase:=False).Offset(0, -1).Column) _
).Select
End With
The whole VBA is:
Private Sub CommandButton1_Click()
Dim my_files As String
Dim folder_path As String
Dim wb As Workbook, lRow As Long
Dim ws As Worksheet, LR As Long
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long
folder_path = "C:\Users\XXXX\Desktop\"
my_files = Dir(folder_path & "\*.xlsx")
Do While my_files <> vbNullString
Set wb = Workbooks.Open(folder_path & "\" & my_files)
Set ws = wb.Worksheets("Sheet0")
'INSERT COLUMN AND PASTE FILE NAME IN ALL ROWS UNTIL LAST ROW
LR = ws.Range("B9").End(xlDown).Row
ws.Columns(1).Select
ActiveCell.EntireColumn.Insert
ws.Range("A8").Value = "Title"
ws.Range("A9:A" & LR).Value = ActiveWorkbook.Name
'INSERT COLUMN AND PASTE CELL A5 VALUE IN ALL ROWS UNTIL LAST ROW
ws.Columns(2).Select
ActiveCell.EntireColumn.Insert
ws.Range("B8").Value = "Duration"
ws.Range("B9:B" & LR).Value = ws.Range("E5").Value
'DELETE A1:A7 ROWS
ws.Range("A1:A7").EntireRow.Delete
'DELETE ORGANIZATION COLUMN
Dim rng As Range
With Worksheets("Sheet0").Range("A1:BB1")
Set rng = Worksheets("Sheet0").Range("A1:BB1").Find(What:="Organization", _
lookat:=xlWhole, MatchCase:=False)
Do While Not rng Is Nothing
rng.EntireColumn.Delete
Set rng = .FindNext
Loop
End With
'SELECT AND DELETE ALL COLUMNS BETWEEN UNSUBSCRIBED AND WEBINAR QUESTION 1
With Worksheets("Sheet0").Range("A1:BB1")
Range(Worksheets("Sheet0").Range("A1:BB1").Find(What:="Unsubscribed", LookIn:=xlValues, MatchCase:=False).Offset(0, 1), _
Cells(Worksheets("Sheet0").Cells(Worksheets("Sheet0").Rows.Count, "A").End(xlUp).Row, _
Worksheets("Sheet0").Range("A1:BB1").Find(What:="Webinar Question 1", LookIn:=xlValues, MatchCase:=False).Offset(0, -1).Column) _
).Select.Delete
End With
Set wsCopy = Worksheets("Sheet0")
Set wsDest = Workbooks("Book1.xlsm").Worksheets("Sheet2")
lCopyLastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1).Row
lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row
wsCopy.Range("A2:BB1" & lCopyLastRow).Copy _
wsDest.Range("A" & lDestLastRow)
wb.Close True
my_files = Dir()
Loop
MsgBox ("All Files Are Updated")
End Sub
For clarification, the worksheet where I have the VBA has Sheet1 and Sheet2, and the file that i am modifying has Sheet0.
What am I missing? Thank you very much and have a nice day.
I am trying to compile data from one large workbook (that will be downloaded once a month) to one that is more concise. I will be pulling in new data every month. I will know the name of the source file and it's location.
Below is the code I am trying to run. It appears to run without errors (going thru all the FOR's and Do Until's) but is just not moving the data from the source file to the destination file. The variable information I am using is column O starting on line 14 of the destination WB. I am trying to sort thru column A of the source WB for some text and the variable from the destination WB. If I have a match I am trying to offset from the matching cell (down 3 rows and right 2 columns) and copy that information to an offset cell on the destination WB (left 4 columns on the same row). Also copying from down 10 rows and right 2 columns on the source to down row 1 and left 4 columns on the destination.
Sub Get_Scorecard()
Dim SourceFile As String
Dim DestFile As String
Dim SourceWB As Workbook
Dim SourceWS As Worksheet
Dim DestWB As Workbook
Dim DestWS As Worksheet
Dim path As String
Dim Msg As String
Dim SCount As Long
Dim sourcestart As Range
Dim TechName As String
'Set starting cell on Dest WS
Range("O14").Activate
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
'Set all the WB's and WS's
path = Application.ThisWorkbook.path & "\"
SourceFile = path & "March Test.xlsx"
DestFile = path & "JobSteps 2019 Test.xlsm"
Set SourceWB = Application.Workbooks.Open(SourceFile)
Set SourceWS = SourceWB.Sheets(1)
Set DestWB = Application.Workbooks.Open(DestFile)
Set DestWS = DestWB.Sheets(1)
'Start in O14 on the Dest WS and loop down till column O is empty
Do Until IsEmpty(ActiveCell.Value)
TechName = ActiveCell.Value
DestStart = ActiveCell.Address
'Start in Cell A2 on the soure WS and search for tech from Dest WS
For SCount = 2 To 700
If SourceWS.Range("A" & SCount).Text = "Provisioning*" & _
TechName & "*" Then
'copy info from 2 offset cells from SourceWS to 2 offset cells on DestWS
'I am offseting 4 columns to left on the DestWS just to see if they appear
DestWS.Range(DestStart).Offset(0, -4).Value = SourceWS.Range(SourceWS.Range _
("A" & SCount).Address).Offset(3, 2).Text
DestWS.Range(DestStart).Offset(-1, -4).Value = SourceWS.Range(SourceWS.Range _
("A" & SCount).Address).Offset(10, 2).Text
End If
Next SCount
'Offset active cell on DestWS by 4 rows
ActiveCell.Offset(4, 0).Activate
Loop
'Close SourceWB
SourceWB.Close
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Range("A1").Activate
End Sub
Below is my code, where I am facing an issue. From different workbooks I need to create 3 new sheets in new workbook. In one I have to filter data based on name of sheet from another workbook. I've stucked with copy filtered data to a new workbook. before that all works fine.
Sub Click()
Dim xRow As Long
Dim wbnew, wb1, wb2, wb3, wb4 As Workbook
Dim sht, Data As Worksheet
Dim sh1, sh2, Filter As String
Dim Name As String
Dim rng As Range
'openin files to work with
Workbooks.Open filename:="C:\Users\File1.xlsx", ReadOnly:=True
Workbooks.Open filename:="C:\Users\File2.xlsx", ReadOnly:=True
Workbooks.Open filename:="C:\Users\File3.xlsx", ReadOnly:=True
Workbooks.Open filename:="C:\Users\File4.xlsx", ReadOnly:=True
wb1 = "File1.xlsx"
wb2 = "File2.xlsx"
Set wb3 = Workbooks("File3.xlsx")
'here I create a temporary file
Set wbnew = Workbooks.Add
ActiveSheet.Name = "Data"
'defining columns I will work with
sh1 = wb3.ActiveSheet.Range("A" & i).Value
sh2 = wb3.ActiveSheet.Range("B" & i).Value
Name = wb3.ActiveSheet.Range("F" & i).Value
Filter = wb3.ActiveSheet.Range("C" & i).Value
'main goal is to copy data from 3 different files to new workbook. Below starting with copying data
Workbooks(wb1).Worksheets(sh1).Copy _
Before:=wbnew.Sheets(1)
Workbooks(wb2).Worksheets(sh2).Copy _
Before:=wbnew.Sheets(2)
'from third file I have to autofilter data for column U in File4.xlsx with criteria from File3.xlsx defined above
Set wb4 = Workbooks("File4.xlsx")
wb4.Activate
xRow = wb4.Worksheets("Transactions").Range("A1").End(xlDown).Row
wb4.Worksheets("Transactions").AutoFilterMode = False
wb4.Worksheets("Transactions").Range("A:U").AutoFilter Field:=21, Criteria1:=Filter, Operator:=xlFilterValues
'try to copy result from autofilter to new workbook to have 3 new sheets, but having an error, also I tried range copy without success
Workbooks(wb4).ActiveSheet.Range("A1:U" & xRow).SpecialCells(xlCellTypeVisible).Copy _
Destination:=wbnew.Sheets("Data")
wb4.Worksheets("Transactions").AutoFilterMode = False
End Sub
I appreciate your advice. Thank you
(Written on my phone, there may be typos): Use advanced filter:-
Sub Click()
Dim xRow As Long
Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook, wb4 As Workbook, wbNew as workbook
Dim sht as worksheet, Data As Worksheet
Dim sh1 as string, sh2 as string, Filter As String
Dim Name As String
Dim rng As Range
'openin files to work with
set wb1 = Workbooks.Open(filename:="C:\Users\File1.xlsx", ReadOnly:=True)
set wb2 = Workbooks.Open(filename:="C:\Users\File2.xlsx", ReadOnly:=True)
set wb3 = Workbooks.Open(filename:="C:\Users\File3.xlsx", ReadOnly:=True)
set wb4 = Workbooks.Open(filename:="C:\Users\File4.xlsx", ReadOnly:=True_
set wbNew = workbooks.add()
dim i as long 'this was missing
i = 1 'what should this be?
'defining columns I will work with
with wb3.Sheets(1)
sh1 = .Range("A" & i).Value
sh2 = .Range("B" & i).Value
Name = .Range("F" & i).Value
Filter = .Range("C" & i).Value
end with
wb3.close false
'main goal is to copy data from 3 different files to new workbook. Below starting with copying data
wb1.Worksheets(sh1).Copy Before:=wbnew.Sheets(1)
wb1.close false
wb2.Worksheets(sh2).Copy before:=wbnew.Sheets(2)
wb2.close false
'from third file I have to autofilter data for column U in File4.xlsx with criteria from File3.xlsx defined above
with wb4.Worksheets("Transactions")
xRow =.Range("A1").End(xlDown).Row
.range("Z1") = .range("U1") 'I assume Z is clear - insert heading
.range("Z2") = filter 'insert value
.range("a1:u1").copy wbnew.sheets("Data").range("a1") 'copy headings
.range("a1:u" & xrow).AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=.range(2z1:z2"), _
CopyToRange:=wbnew.Sheets("Data").range("A1:u1")
End With
End Sub
You need to specify a range for your destination:
Workbooks(wb4).ActiveSheet.Range("A1:U" & xRow).SpecialCells(xlCellTypeVisible).Copy _
Destination:=wbnew.Sheets("Data").Range("A1:U" & xRow)
Getting above error in Title while trying to open the file in Macro to copy the data from that file to a central file(in which the macro is run). Checked the path and everything is fine. The Macro has opened and copied 10 files before the 11th instance of opening the file in the similar way however the error occurs on 11th file only. Tried changing position of the file access(by putting 12th file in sequence after 10th) however same error occurs.
Declared dr_x and fl_x as strings
Dim sheet As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
dr_1 = "<path for the directory 1>"
Workbooks.Open (dr_1 & fl_1)
Windows("<file name 1.xlsx>").Activate
Range("A1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Copy
Windows("<Target File Name.xlsm>").Activate
Sheets("Tab_File1").Select
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Not quite sure what you're doing, but removing all the SELECT & ACTIVATE statements makes the code run a lot smoother.
The SourceFiles array contains the paths to all the workbooks you want to open and copy from.
Public Sub Test()
Dim TargetFile As Workbook, SourceFiles() As Variant
Dim tgtLastCell As Range, srcLastCell As Range
Dim tgtWrkSht As Worksheet, srcWrkSht As Worksheet
Dim fle As Variant
Dim wrkBk As Workbook
SourceFiles = Array("C:\MyPath\Book1.xlsx", _
"C:\MyOtherPath\Book2.xlsx")
Set TargetFile = ThisWorkbook 'If target sheet is in file containing this code.
'or
'Set TargetFile = Workbooks.Open("C:\SomePath\Book3.xlsx")
Set tgtWrkSht = TargetFile.Worksheets("Sheet1")
For Each fle In SourceFiles
'Find current last cell in target sheet.
Set tgtLastCell = LastCell(tgtWrkSht)
'Open source file, set reference to sheet1 and find the last cell containing data.
Set wrkBk = Workbooks.Open(fle)
Set srcWrkSht = wrkBk.Worksheets("Sheet1")
Set srcLastCell = LastCell(srcWrkSht)
'Copy & paste contents of sheet on to end of target sheet.
With srcWrkSht
.Range(.Cells(1, 1), srcLastCell).Copy Destination:=tgtWrkSht.Cells(tgtLastCell.Row + 1, 1)
End With
'Close source workbook.
wrkBk.Close False
Next fle
End Sub
Public Function LastCell(wrkSht As Worksheet) As Range
Dim lLastCol As Long, lLastRow As Long
On Error Resume Next
With wrkSht
lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
If lLastCol = 0 Then lLastCol = 1
If lLastRow = 0 Then lLastRow = 1
Set LastCell = wrkSht.Cells(lLastRow, lLastCol)
End With
On Error GoTo 0
End Function
The answer I got for the above issue is below -
Sub Consolidate()
Path = "\\Source-Path\"
Filename = Dir(Path & "*.xlsx")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
End Sub
where "\Source-Path\" is the folder where all source files(from where the data is to be copied) are stored.