I am trying to copy some data from one workbook to another, with checking certain cells content from 2 files. Below is my code:
Sub GetFileCopyData()
Dim Fname As String
Dim SrcWbk As Workbook
Dim DestWbk As Workbook
Dim miesiac() As Variant
Dim m_i, i, wiersz_nazw As Integer
Dim Msc, nazw As String
miesiac = Array(styczeń, luty, marzec, kwiecień, maj, czerwiec, lipiec, sierpień, wrzesień, październik, listopad, grudzień)
Set DestWbk = ThisWorkbook
Set SrcWbk = ActiveWorkbook
Fname = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", Title:="Select a File")
If Fname = "False" Then Exit Sub
Set SrcWbk = Workbooks.Open(Fname)
Set DestWbk = ActiveWorkbook
Msc = SrcWbk.Cells(2, 13).Text
m_i = szukaj(miesiac, Msc)
nazw = Cells(3, 4).Text
For i = 1 To 100 Step 1
If nazw Like "*" & SrcWbk.Cells(i, 24) & "*" Then
wiersz_nazw = i: Exit For
End If
Next
SrcWbk.Cells(wiersz_nazw, 2).Copy DestWbk.Cells(m_i + 7, 3)
End Sub
Function szukaj(ByRef lista As Variant, ByVal wartosc As String)
Dim found As Integer, foundi As Integer ' put only once
found = -1
For foundi = LBound(lista) To UBound(lista):
'If lista(foundi) = wartosc Then
If StrComp(lista(foundi), wartosc, vbTextCompare) = 0 Then
found = foundi: Exit For
End If
Next
szukaj = found
End Function
It gets runtime 438 error in this line:
Msc = SrcWbk.Cells(2, 13).Text
The script have to get text parameter from source workbook cell 2,13, then take number for this text from array. Then scrip has to get text parameter from destination work book cell 3,4 and search for it in source workbook. Then I can copy some data.
This covers most of the comments. I think it should work, but you might have to check the workbook/sheet names as I wasn't entirely clear in all cases.
And check I have the wiersz_nazw bit correct.
The original 438 error was caused because Cells needs a sheet parent, not a workbook parent.
Sub GetFileCopyData()
Dim Fname As String
Dim SrcWbk As Workbook
Dim DestWbk As Workbook
Dim miesiac() As Variant
Dim m_i As Variant, i As Long, wiersz_nazw As Variant
Dim Msc As String, nazw As String 'each one needs to be specified
miesiac = Array(styczen, luty, marzec, kwiecien, maj, czerwiec, lipiec, sierpien, wrzesien, pazdziernik, listopad, grudzien)
Set DestWbk = ThisWorkbook 'file containing code
Fname = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", Title:="Select a File")
If Fname = "False" Then Exit Sub
Set SrcWbk = Workbooks.Open(Fname)
Msc = SrcWbk.Worksheets(1).Cells(2, 13).Text
m_i = Application.Match(Msc, miesiac, 0)
If Not IsNumeric(m_i) Then m_i = -1
nazw = SrcWbk.Worksheets(1).Cells(3, 4).Text 'change workbook/sheet as necessary
wiersz_nazw = Application.Match("*" & nazw & "*", SrcWbk.Worksheets(1).Range("X1:X100"), 0)
If IsNumeric(wiersz_nazw) Then
SrcWbk.Worksheets(1).Cells(wiersz_nazw, 2).Copy DestWbk.Worksheets(1).Cells(m_i + 7, 3) 'change sheets as necessary
End If
End Sub
Related
I want to use VBA to create a summary sheet in this workbook (storage workbook) that I am currently working in to go through multiple reports (over 100) and pull certain values.
Each report contains 10+ sheets, but I am only interested in copying cells A4:A5 from the sheets titled Day1, Day2, Day3, etc.
I found success using the code below and creating a module for each Day 1, Day 2, Day 3, etc.
Sub Day1_values()
Dim basebook As Workbook
Dim mybook As Workbook
Dim ws As Worksheet
Dim rnum As Long
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String
Dim Cnum As Integer
Dim cell As Range
Dim foldername As String
Dim getpath As String
Dim myFilePath As String
SaveDriveDir = CurDir
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then
MyPath = .SelectedItems(1)
End If
End With
If MyPath <> "" Then
ChDrive MyPath
ChDir MyPath
FNames = Dir("*.xlsm")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If
Application.ScreenUpdating = False
Set basebook = ThisWorkbook
rnum = 2
Do While FNames <> ""
Set mybook = Workbooks.Open(FNames)
' This will add the workbook name in column A
basebook.Worksheets(1).Cells(rnum, "A").Value = mybook.Name
basebook.Worksheets(1).Cells(rnum, "B").Value = mybook.Path
Cnum = 3 'begin pasting the values in column 3
For Each cell In mybook.Worksheets("Day1").Range("A4:A5")
basebook.Worksheets(1).Cells(rnum, Cnum).Value = cell.Value
Cnum = Cnum + 1
Next cell
mybook.Close False
rnum = rnum + 1
FNames = Dir()
Loop
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End If
End Sub
The problem is that each workbook contains a different number of days. For example report 1 has day1 - day5 and report 2 only has day1 - day2.
The above code doesn't work when I create a module for Day3 because it will see that report 2 does not have a Day3 and the code will break because subscript out of range.
Does anyone have any idea how I can manipulate the code in a way to say that for each workbook, if the sheet name contains Day* to copy cells A4:A5 and paste them in my storage workbook?
There was a similar post here: Loop through worksheets with a specific name and they successfully used this code for their problem:
If ws.Name Like "danger" & "*" Then
ws.Range("A1").Interior.ColorIndex = 37
End If
I just don't know how to add that into my existing code.
Try something like this:
Sub ImportWorksheetData()
Dim basebook As Workbook, mybook As Workbook
Dim ws As Worksheet
Dim MyPath As String
Dim rwResults As Range, nm As String, f
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then
MyPath = .SelectedItems(1)
End If
End With
If Len(MyPath) = 0 Then Exit Sub 'no folder chosen
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\" 'ensure trailing \
Set basebook = ThisWorkbook
Set rwResults = basebook.Worksheets(1).Rows(2)
f = Dir(MyPath & "*.xlsm")
Do While Len(f) > 0
Set mybook = Workbooks.Open(MyPath & f)
For Each ws In mybook.Worksheets
'Does the worksheet name match our pattern?
nm = UCase(Replace(ws.Name, " ", "")) 'ignore spaces when checking
If nm Like "DAY#" Or nm Like "DAY##" Then '# = any digit
rwResults.Columns("A").Value = f
rwResults.Columns("B").Value = MyPath
rwResults.Columns("C").Value = ws.Name
rwResults.Columns("D").Value = ws.Range("A4").Value
rwResults.Columns("E").Value = ws.Range("A5").Value
Set rwResults = rwResults.Offset(1, 0) 'move down for next sheet
End If
Next ws
mybook.Close False 'no save
f = Dir()
Loop
End Sub
Collect Data from Workbooks
Option Explicit
Sub CollectData()
Const sPattern As String = "*.xlsm"
Const swsPatternLCase As String = "day*"
Const sAddressesList As String = "A4,A5" ' add more
Const dID As Variant = 1 ' or e.g. "Sheet1" - is safer
Const dFirst As String = "A2" ' Destination First Cell Address
Const dLower As Long = 3 ' first column to write the cell values to
Dim dwb As Workbook: Set dwb = ThisWorkbook
Dim sPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = dwb.Path & "\"
If .Show = -1 Then
sPath = .SelectedItems(1)
End If
End With
If sPath = "" Then Exit Sub ' dialog canceled
Dim sName As String: sName = Dir(sPath & "\" & sPattern)
If Len(sName) = 0 Then
MsgBox "No files in the Directory"
Exit Sub
End If
Dim sAddresses() As String: sAddresses = Split(sAddressesList, ",")
Dim aUpper As Long: aUpper = UBound(sAddresses)
Dim cCount As Long: cCount = dLower + aUpper
Application.ScreenUpdating = False
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim Dat As Variant: ReDim Dat(1 To cCount)
Dim swb As Workbook
Dim sws As Worksheet
Dim n As Long
Dim a As Long
' Write each worksheet's results to an array ('Dat') and add the array
' to the dictionary ('dict').
Do While sName <> ""
Set swb = Workbooks.Open(sPath & "\" & sName)
Dat(1) = swb.Name
Dat(2) = sPath ' or swb.Path - it's always the same '***
For Each sws In swb.Worksheets
If LCase(sws.Name) Like swsPatternLCase Then
'Dat(2) = sws.Name ' looks more useful '***
For a = 0 To aUpper
Dat(dLower + a) = sws.Range(sAddresses(a)).Value
Next a
n = n + 1
dict.Add n, Dat
End If
Next sws
swb.Close False
sName = Dir()
Loop
Dim rCount As Long: rCount = dict.Count
If rCount > 0 Then
' Write the results from the arrays in the dictionary
' to a 2D one-based array ('dData').
Dim dData As Variant: ReDim dData(1 To rCount, 1 To cCount)
Dim r As Long
Dim c As Long
For Each Dat In dict.Items
r = r + 1
For c = 1 To cCount
dData(r, c) = Dat(c)
Next c
Next Dat
With dwb.Worksheets(dID).Range(dFirst).Resize(, cCount)
' Write the results to the destination range (in one go).
.Resize(rCount).Value = dData
' Clear the contents below the destination range.
.Resize(.Worksheet.Rows.Count - .Row - rCount + 1) _
.Offset(rCount).ClearContents
.EntireColumn.AutoFit
End With
dwb.Save
End If
Application.ScreenUpdating = True
MsgBox "Data collected.", vbInformation, "Collect Data"
End Sub
I have a folder, which I need to bring in 29 files into 29 worksheets in a template wb. there are 31 total worksheets, but I need to start placing them after sheet 2.
I first place the relevant sheet names into an array:
Dim wbTemplate As Workbook: Set wbTemplate = ThisWorkbook
Dim wsInputs As Worksheet: Set wsInputs = wbTemplate.Worksheets("Inputs")
Dim strDate As String: strDate = InputBox("Please Enter Date of Data (mm/dd/yyyy) : ", Default:=Format(Now, "mm/dd/yyyy"))
Dim strFolderName As String: strFolderName = InputBox("Please Enter Data Folder Date (mm.dd.yy) Include 0's: ", Default:=Format(Now, "mm.dd.yy"))
'place wbTemplate sheet names into an array
With wbTemplate
Dim varWsName, i
Dim ws As Worksheet
ReDim varWsName(1 To Sheets.Count)
For i = 1 To Sheets.Count
Select Case ws.Name
Case "Inputs", "Data --->>>"
Case Else
ws(i) = ThisWorkbook.Sheets(i).Name
End Select
Next
.wsInputs.Range("B1").Value = strDate
.wsInputs.Range("B2").Value = strFolderName
End With
getting an object variable or with block not set on this line:
Select Case ws.Name
and then I want to know if this line will properly start placing the first file in the folder in sheet 1 after the case statement, and then second file will place in sheet 2 and so forth:
With wb.Worksheets("Sheet1")
.UsedRange.Copy Destination:=wbTemplate.Worksheets(varWsName(i))
End With
Rest of code:
Option Explicit
Sub Update_Data_And_OPR()
Dim wbTemplate As Workbook: Set wbTemplate = ThisWorkbook
Dim wsInputs As Worksheet: Set wsInputs = wbTemplate.Worksheets("Inputs")
Dim strDate As String: strDate = InputBox("Please Enter Date of Data (mm/dd/yyyy) : ", Default:=Format(Now, "mm/dd/yyyy"))
Dim strFolderName As String: strFolderName = InputBox("Please Enter Data Folder Date (mm.dd.yy) Include 0's: ", Default:=Format(Now, "mm.dd.yy"))
'place wbTemplate sheet names into an array
With wbTemplate
Dim varWsName, i
Dim ws As Worksheet
ReDim varWsName(1 To Sheets.Count)
For i = 1 To Sheets.Count
Select Case ws.Name
Case "Inputs", "Data --->>>"
Case Else
ws(i) = ThisWorkbook.Sheets(i).Name
End Select
Next
.wsInputs.Range("B1").Value = strDate
.wsInputs.Range("B2").Value = strFolderName
End With
'compile all files in folder into wbTemplate
Dim filePath As String: filePath = strFolderName & "*.xlsx"
Dim fileName As String: fileName = Dir(filePath)
Dim wb As Workbook
Dim k As Long
Do While fileName <> ""
Set wb = Workbooks.Open(strFolderName & fileName)
With wb.Worksheets("Sheet1")
.UsedRange.Copy Destination:=wbTemplate.Worksheets(varWsName(i))
End With
wb.Close
fileName = Dir
Loop
End Sub
I am generating 7 csv files and 1 excel file : A.xls from my R code. I need to copy each csv file to A.xls as a separate sheet and append it to A.xls
Can you just use VB to do the job, instead of VB?
' Merge data from multiple files into separate sheets
Sub R_AnalysisMerger2()
Dim WSA As Worksheet
Dim bookList As Workbook
Dim SelectedFiles As Variant
Dim NFile As Long
Dim FileName As String
Dim Ws As Worksheet, vDB As Variant, rngT As Range
Dim vFn, myFn As String
Application.ScreenUpdating = False
SelectedFiles = Application.GetOpenFilename(filefilter:="Excel Files (*.csv*), *.csv*", MultiSelect:=True)
If IsEmpty(SelectedFiles) Then Exit Sub
For NFile = LBound(SelectedFiles) To UBound(SelectedFiles)
FileName = SelectedFiles(NFile)
vFn = Split(FileName, "\")
myFn = vFn(UBound(vFn))
myFn = Replace(myFn, ".csv", "")
Set bookList = Workbooks.Open(FileName, Format:=2)
Set WSA = bookList.Sheets(1)
vDB = WSA.UsedRange
bookList.Close (0)
Set Ws = Sheets.Add(after:=Sheets(Sheets.Count))
ActiveSheet.Name = myFn
Ws.Range("a1").Resize(UBound(vDB, 1), UBound(vDB, 2)) = vDB
Next
Application.ScreenUpdating = True
End Sub
I have the following code albeit incomplete as i am unsure how i can populate multiple columns and rows.
Code
Sub VlookMultipleWorkbooks()
Dim lookFor As Range
Dim srchRange As Range
Dim book1 As Workbook
Dim book2 As Workbook
Dim book1Name As String
book1Name = "destination.xls" 'modify it as per your requirement
Dim book1NamePath As String
book1NamePath = ThisWorkbook.Path & "\" & book1Name
Dim book2Name As String
book2Name = "source.xls" 'modify it as per your requirement
Dim book2NamePath As String
book2NamePath = ThisWorkbook.Path & "\" & book2Name
' Set book1 = ThisWorkbook
Set book1 = Workbooks(book1Name)
If IsOpen(book2Name) = False Then Workbooks.Open (book2NamePath)
Set book2 = Workbooks(book2Name)
Set lookFor = book1.Sheets(1).Cells(2, 1) ' value to find
Set srchRange = book2.Sheets(1).Range("A:B") 'source
lookFor.Offset(0, 1).Value = Application.VLookup(lookFor, srchRange, 2, False)
End Sub
My source file has the following structure
Name Value1
My destination file has the following structure
Name Value1
Problem 1
Currently the code only populates a single cell where i would like it to populate allow rows.
Problem 2
I need to be able to populate multiple columns. For example.
Name Value1 Value2, etc
Problem 3
There are multiple source files that need to merge into a single master list.
EDIT: You could modify your initial design to take in two Range objects and an offset, then iterate as necessary. You'll need to open your workbooks and assign the Range objects elsewhere, but that doesn't seem to be the challenge right now. (Below is untested):
Sub EvenCoolerVLookup(SourceRange As Range, OffsetColumns As Long, LookupRange As Range)
Dim Cell As Range
'vet range objects and make sure they fail an Is Nothing test
'....
For Each Cell In SourceRange
'do any special prep here
'...
Cell.Offset(0, OffsetColumns).Value = Application.VLookup(Cell, LookupRange, 2, False)
'do any special cleanup here
'...
Next Cell
'do anything else here
'....
End Sub
That should help you solve Problem 1. To solve Problem 2, you won't be able to use Application.Vlookup, but you can instead use Range.Find to return a Range object, from which you can grab the row via Range.Row.
Original Response: This should work to combine source files for Problem 3. The results will be saved as an xlsx file to the same directory as the file from which the code is run:
Option Explicit
'let's do some combining y'all!
Sub CombineSelectedFiles()
Dim TargetFiles As FileDialog
Dim TargetBook As Workbook, CombinedBook As Workbook
Dim TargetSheet As Worksheet, CombinedSheet As Worksheet
Dim TargetRange As Range, AddNewRange As Range, _
FinalRange As Range
Dim LastRow As Long, LastCol As Long, Idx As Long, _
LastCombinedRow As Long
Dim CombinedFileName As String
Dim RemoveDupesArray() As Variant
'prompt user to pick files he or she would like to combine
Set TargetFiles = UserSelectMultipleFiles("Pick the files you'd like to combine:")
If TargetFiles.SelectedItems.Count = 0 Then Exit Sub '<~ user clicked cancel
'create a destination book for all the merged data
Set CombinedBook = Workbooks.Add
Set CombinedSheet = CombinedBook.ActiveSheet
'loop through the selected workbooks and combine data
For Idx = 1 To TargetFiles.SelectedItems.Count
Set TargetBook = Workbooks.Open(TargetFiles.SelectedItems(Idx))
Set TargetSheet = TargetBook.ActiveSheet
If Idx = 1 Then
TargetSheet.Cells.Copy Destination:=CombinedSheet.Cells(1, 1)
Else
LastRow = FindLastRow(TargetSheet)
LastCol = FindLastCol(TargetSheet)
With TargetSheet
Set TargetRange = .Range(.Cells(2, 1), .Cells(LastRow, LastCol))
End With
LastCombinedRow = FindLastRow(CombinedSheet)
With CombinedSheet
Set AddNewRange = .Range(.Cells(LastCombinedRow + 1, 1), _
.Cells(LastCombinedRow + 1 + LastRow, LastCol))
End With
TargetRange.Copy Destination:=AddNewRange
End If
TargetBook.Close SaveChanges:=False
Next Idx
'set up a final range for duplicate removal
LastCombinedRow = FindLastRow(CombinedSheet)
With CombinedSheet
Set FinalRange = .Range(.Cells(1, 1), .Cells(LastCombinedRow, LastCol))
End With
'populate the array for use in the duplicate removal
ReDim RemoveDupesArray(LastCol)
For Idx = 0 To (LastCol - 1)
RemoveDupesArray(Idx) = Idx + 1
Next Idx
FinalRange.RemoveDuplicates Columns:=Evaluate(RemoveDupesArray), Header:=xlYes
'save the results
CombinedFileName = ThisWorkbook.Path & "\Combined_Data"
Application.DisplayAlerts = False
CombinedBook.SaveAs FileName:=CombinedFileName, FileFormat:=51
CombinedBook.Close SaveChanges:=False
Application.DisplayAlerts = True
End Sub
'prompt user to select files then return the selected fd object
Public Function UserSelectMultipleFiles(DisplayText As String) As FileDialog
Dim usmfDialog As FileDialog
Set usmfDialog = Application.FileDialog(msoFileDialogOpen)
With usmfDialog
.AllowMultiSelect = True
.Title = DisplayText
.ButtonName = ""
.Filters.Clear
.Filters.Add ".xlsx files", "*.xlsx"
.Filters.Add ".xlsb files", "*.xlsb"
.Filters.Add ".xlsm files", "*.xlsm"
.Filters.Add ".xls files", "*.xls"
.Filters.Add ".csv files", "*.csv"
.Filters.Add ".txt files", "*.txt"
.Show
End With
Set UserSelectMultipleFiles = usmfDialog
End Function
'identify last row in a worksheet
Public Function FindLastRow(Sheet As Worksheet) As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
FindLastRow = Sheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Else
FindLastRow = 1
End If
End Function
'identify last col in a worksheet
Public Function FindLastCol(Sheet As Worksheet) As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
FindLastCol = Sheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Else
FindLastCol = 1
End If
End Function
I need to copy the excel sheets and make it into one consolidated excel workbook . After consolidating the worksheet , all files need to move to new folder called "Orginial".
The folder should be be created where the file is located.
Problem is file will be selected by the user itself
I am using getfilename to get the path from the user
Steps invloving :
Step1 : for example : if user needs to select
C :\my documents\worksheet1.xls
C :\my documents\worksheet2.xls
C :\my documents\worksheet3.xls
step2 :file should be consolidated as worksheet1.xls and
step3: folder should be created in the c:\my documents\original
and all worksheet1, worksheet2,worksheet3 , should move into "original" folder
I have code for consolidting the excelsheets . But i dont know how to create a folder within the path .Please help me
Below is the code
Option Explicit
Sub copyma()
Dim wb(20) As Variant
Dim ws(20) As Variant
Dim lastrow As Variant
Dim lastr(20) As Variant
Dim nextrow As Variant
Dim tempwb As Variant
Dim tempws As Worksheet
Dim tempfile As Variant
Dim fnum As Variant
Dim ws1 As Worksheet
Dim m As Integer
Dim ffiles(20) As Variant
Dim nextlastrow As Variant
Dim lastcopyrow As Variant
Dim lastcopycol As Variant
Set ws1 = Worksheets("sheet1")
fnum = ws1.Range("b3").Value
'selecting temporary files
MsgBox " plz select the temp sheet"
tempfile = Application.GetOpenFilename
Set tempwb = Workbooks.Open(Filename:=tempfile)
Set tempws = tempwb.Worksheets("sheet1")
tempws.Cells.Clear
' sleecting number of files
For m = 1 To fnum
MsgBox " Please Select " & m & "files"
ffiles(m) = Application.GetOpenFilename
Next m
' opening the files and copying to the temp sheet
For m = 1 To fnum
Set wb(m) = Workbooks.Open(Filename:=ffiles(m))
Set ws(m) = wb(m).Worksheets("sheet")
ws(m).AutoFilterMode = False
' finding the lastrow of the temp sheet
lastrow = tempws.Range("A" & tempws.Rows.Count).End(xlUp).Row
lastr(m) = ws(m).Range("A" & ws(m).Rows.Count).End(xlUp).Row
MsgBox lastr(m)
nextlastrow = lastrow + 1
With ws(m)
lastcopyrow = .Range("A" & .Rows.Count).End(xlUp).Row
lastcopycol = ws(m).Cells(1, .Columns.Count).End(xlToLeft).Column
' lastcol = ws2.Cells(1, .Columns.Count).End(xlToLeft).Column
If m = 1 Then
.Range("A1", .Cells(lastcopyrow, lastcopycol)).Copy tempws.Cells(lastrow, 1)
Else
.Range("A2", .Cells(lastcopyrow, lastcopycol)).Copy tempws.Cells(nextlastrow, 1)
End If
End With
wb(m).Close
Next m
tempws.Name = "sheet"
tempwb.Save
End Sub
'Get file path
Dim outfolder As String
outfolder = Mid(tmpfile, 1, InStrRev(tmpfile, "\")) & "original"
'Check if directory exists and create it if it does not
If Dir(outfolder) = "" Then
MkDir outfolder
End If
Considering you have the base path at your disposal:
Sub Create_Path()
Dim sBase_Path As String
Dim sNew_Path As String
sBase_Path = "U:\"
sNew_Path = sBase_Path & "New_Path" 'Define yourself
MkDir sNew_Path
End Sub