I've only been at VBA for about 2 weeks so I need some assistance. I have a loop setup to copy 7 cells across on workbook (A), then paste them vertically in a column on workbook (B). For some reason the code is working but will not paste any data... I've been trying to troubleshoot for a while now with no luck.
Here is a screenshot of the sheet I'm copying data from.
Here is a screenshot of the workbook I'm pasting too.
Sub pullSecEquipment()
Dim path As String
Dim ThisWB As String
Dim wbDest As Workbook
Dim shtDest As Worksheet
Dim Filename As String
Dim Wkb As Workbook
Dim CopyRng As Range, DestRng As Range
Dim lRow As Integer
Dim destLRow As Integer
Dim UpdateDate As String
ThisWB = ActiveWorkbook.Name
Dim selectedFolder
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
selectedFolder = .SelectedItems(1) & "\"
End With
path = selectedFolder
Application.EnableEvents = False
Application.ScreenUpdating = False
Set shtDest = Workbooks("GPnewchapterTEST2.xlsm").Worksheets("START")
'clear content of destination table
shtDest.Rows("8:" & Rows.Count).ClearContents
Filename = Dir(path & "\*.xls*", vbNormal)
If Len(Filename) = 0 Then Exit Sub
Do Until Filename = vbNullString
Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename)
'MsgBox Filename
'''''
'SEC
'''''
If InStr(Filename, "Equipment") <> 0 Then
'''
'' Equipment Hours
'''
Dim range1 As Range
Set range1 = Range("E:K")
If shtDest.Name Like "*-*" Then
'last row
destLRow = Wkb.Sheets(1).Cells.Find(what:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
'1st row
lRow = Wkb.Sheets(1).Cells.Find(what:="EQUIPMENT DESCRIPTION", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
Dim i As Integer
For i = lRow To destLRow
Set CopyRng = Wkb.Sheets(1).Range(Cells(i, 5).Address, Cells(i, 11).Address)
Set DestRng = shtDest.Range("O" & shtDest.Cells(Rows.Count, 1).End(xlUp).Row + 1)
CopyRng.Copy
DestRng.PasteSpecial Transpose:=True
Application.CutCopyMode = False 'Clear Clipboard
i = i + 2
Next i
End If
End If
Filename = Dir()
Loop
MsgBox "Done!"
End Sub
Related
My Code so far does paste the selected data from all the source files, however I also need the source file name to recognize which data belongs to which source file and this name should occur beside the column where data is pasted each time.
Sub OpenFilesCopyPasteVI()
Dim SFile As Workbook
Dim SFname As Worksheet
Dim SFname2 As Worksheet
Dim SFlname As String
Dim I As Long
Dim DFile As Workbook
Dim Acellrng As String
Pth = "C:\XYZ\"
Application.ScreenUpdating = False
Set SFile = ThisWorkbook
Set SFname = SFile.Worksheets("Sheet1")
Set SFname2 = SFile.Worksheets("Sheet3")
numrows = SFname.Range("A1", Range("A1").End(xlDown)).Rows.Count
For I = 1 To numrows
SFlname = SFname.Range("A" & I).Value
If SFname.Range("A" & I).Value <> "" Then
Workbooks.Open Pth & SFlname
Set DFile = Workbooks(SFlname)
Cells.Find(What:="ABC", LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True).Activate
Acellrng = ActiveCell.Address
Range(Acellrng).Select
ActiveSheet.Range(Selection, Selection.End(xlDown).End(xlToRight)).Copy Destination:=SFile.Worksheets("Sheet3").Cells(SFile.Worksheets("Sheet3").Rows.Count, "C").End(xlUp).Offset(1)
DFile.Close
**'I need help to automate this part where I need the source file name in the last column each time beside the data pasted**
SFname2.Range("K3", "K18").Value = SFlname
End If
Next I
MsgBox "job done"
Application.ScreenUpdating = True
End Sub
Try this out:
Sub OpenFilesCopyPasteVI()
Const PTH As String = "C:\XYZ\" 'use const for fixed values
Dim SFile As Workbook, SFname As Worksheet, SFname2 As Worksheet
Dim SFlname As String, I As Long, DFile As Workbook
Dim Acellrng As Range, ws As Worksheet, rngDest As Range, rngCopy As Range
Set SFile = ThisWorkbook
Set SFname = SFile.Worksheets("Sheet1")
Set SFname2 = SFile.Worksheets("Sheet3")
Application.ScreenUpdating = False
For I = 1 To SFname.Cells(Rows.Count, "A").End(xlUp).Row
SFlname = SFname.Range("A" & I).Value
If Len(SFlname) > 0 Then
Set DFile = Workbooks.Open(PTH & SFlname)
Set ws = DFile.Sheets(1) 'or other specifc sheet
Set Acellrng = ws.Cells.Find(What:="ABC", _
LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True)
If Not Acellrng Is Nothing Then
Set rngCopy = ws.Range(Acellrng, Acellrng.End(xlDown).End(xlToRight))
Set rngDest = SFname2.Cells(Rows.Count, "C").End(xlUp).Offset(1)
rngCopy.Copy rngDest
'populate the file name in Column K next to the copied data
rngDest.EntireRow.Columns("K").Resize(rngCopy.Rows.Count).Value = SFlname
End If
DFile.Close savechanges:=False
End If
Next I
MsgBox "job done"
Application.ScreenUpdating = True
End Sub
I am cycling through all the Green Tabs in a workbook. When I come to a row of data where there is no value in Column G, I select that row, cut it, and open another workbook entitled "Unpaid AR." In that workbook, I find the first unused row, and Paste. Everything functions properly except for the Paste - nothing pastes, and I have tried several different techniques. Any ideas what could be going wrong?
Public Sub CutNPaste()
Dim ws As Worksheet
Dim ARRange As String
Dim ARFilePath As String
Dim ARcell As Range
Dim CopyRange As String
Dim i As Integer
Dim varRange As String
ARFilePath = "Unpaid AR.xlsx"
For Each ws In ThisWorkbook.Worksheets
ws.Activate
If ws.Tab.ColorIndex = 10 Then 'If Tab is Green, Then...
ReportRows = ActiveSheet.UsedRange.Rows.Count 'Get how many rows in the report
Let ARRange = "G" & "2" & ":" & "G" & ReportRows 'Range to Inspect for Blanks
i = 2
For Each ARcell In Range(ARRange)
Let CopyRange = "A" & i & ":" & "I" & i 'Set the copy range when blank is encountered
If ARcell.Value = "" Then
Range(CopyRange).Select
Selection.Cut
Workbooks.Open ARFilePath 'Open the Unpaid AR workbook
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select 'Find the first open row
ActiveSheet.Paste 'This is where NOTHING happens
Workbooks("Unpaid AR.xlsx").Close SaveChanges:=True 'Save and close destination wkbk
Application.CutCopyMode = False
End If
i = i + 1
Next ARcell
End If
Next ws
End Sub
i change a little bit...
Public Sub CutNPaste()
Dim ws As Worksheet
Dim ARRange As String
Dim ARFilePath As String
Dim ARcell As Range
Dim CopyRange As Range
Dim i As Integer
Dim varRange As String
Dim wkbTarget As Workbook
Dim ReportRows As Long
ARFilePath = ThisWorkbook.Path & "\Unpaid AR.xlsx"
Set wkbTarget = Workbooks.Open(ARFilePath) 'Open the Unpaid AR workbook
For Each ws In ThisWorkbook.Worksheets
If ws.Tab.ColorIndex = 10 Then
ReportRows = ws.UsedRange.Rows.Count
For i = ReportRows To 2 Step -1
Set CopyRange = ws.Range("A" & i & ":" & "I" & i)
If ws.Cells(i, 7).Value = "" Then
CopyRange.Cut Destination:=wkbTarget.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Application.CutCopyMode = False
End If
Next i
End If
Next ws
wkbTarget.Close SaveChanges:=True 'Save and close destination wkbk
End Sub
BR
Bernd
I have multiple workbooks in a folder and i need to copy paste data from some of them based on naming convention. I am copy pasting data based on column names to a master sheet as order of columns in source files is not the same. Code pasted below does the task but it looks for exact match in column names and as a result i am only able to capture 80% of the data as few column names in source files are not an exact match. For eg: A column in the Target file with header Premium is mentioned as Premium # 25% in the Source file. This is just an example.
Sub ImportExcelfiles()
Dim strPath As String
Dim strFile As String
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim bookName As Worksheet
Dim rowCountSource As Long
Dim colCountSource As Long
Dim rowOutputTarget As Long
Dim colOutputTarget As Long
Dim found1 As Range, found2 As Range, j As Long, Cr1 As String, srcRow As Range
'Variables for Sheet - Workbook Name
Dim nameCount As Long
Dim fileName As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'====================================
'SET THE PATH AND FILE TO THE FOLDER
'====================================
strPath = ThisWorkbook.Worksheets("Control").Range("C4")
fileName = ThisWorkbook.Worksheets("Control").Range("C5")
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
'set the target worksheet
Set wsTarget = ThisWorkbook.Worksheets("Master Data")
Set bookName = ThisWorkbook.Worksheets("Workbook Name")
'set the initial output row and column count for master data and workbook name
nameCount = 2
rowOutputTarget = wsTarget.Cells(Rows.Count, 1).End(xlUp).Row
'get the first file
strFile = Dir(strPath & "*.xlsx*")
'loop throught the excel files in the folder
Do While strFile <> ""
If InStr(strFile, fileName) > 0 Then
'open the workbook
Set wbSource = Workbooks.Open(strPath & strFile)
Set wsSource = wbSource.Worksheets("Details")
'get the row and column counts
With wsSource
colCountSource = .Cells(2, Columns.Count).End(xlToLeft).Column
For j = 1 To colCountSource
Cr1 = .Cells(2, j).Value
Set srcRow = .Range("A2", .Cells(1, colCountSource))
Set found1 = srcRow.Find(What:=Cr1, LookAt:=xlWhole, MatchCase:=True)
If Not found1 Is Nothing Then
colCountSource = wsTarget.Cells(1, Columns.Count).End(xlToLeft).Column
Set srcRow = wsTarget.Range("A1", wsTarget.Cells(1, colCountSource))
Set found2 = srcRow.Find(What:=Cr1, LookAt:=xlWhole, MatchCase:=F)
If Not found2 Is Nothing Then
rowCountSource = .Cells(Rows.Count, found1.Column).End(xlUp).Row
.Range(.Cells(3, found1.Column), .Cells(rowCountSource, found1.Column)).Copy
found2.Offset(rowOutputTarget, 0).PasteSpecial Paste:=xlPasteValues
End If
End If
Next j
End With
bookName.Range("A" & nameCount).Value = wbSource.Name
'update output row '2+12-1=13
nameCount = nameCount + 1
rowOutputTarget = rowOutputTarget + rowCountSource - 2
'close the opened workbook
wbSource.Close SaveChanges:=False
End If
'get the next file
strFile = Dir()
Loop
Application.ScreenUpdating = True
MsgBox "Data imported.", vbInformation
End Sub
This code takes approximately 5 mins to copy paste data. Is there a way to optimise it and also solve my problem of missing 20% data.
Because the target column name is the shorter you need to search the source column names for each target column name.
Option Explicit
Sub ImportExcelfiles()
Dim strPath As String, strFile As String, fileName As String
Dim wbSource As Workbook
Dim wsSource As Worksheet, wsTarget As Worksheet
Dim bookName As Worksheet
Dim rowCountSource As Long, colCountSource As Long
Dim colCountTarget As Long
Dim rowOutputTarget As Long, colOutputTarget As Long
Dim found1 As Range, found2 As Range, j As Long
Dim Cr1 As String, srcRow As Range
'Variables for Sheet - Workbook Name
Dim nameCount As Long
Dim t0 As Single: t0 = Timer
strPath = ThisWorkbook.Worksheets("Control").Range("C4")
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
fileName = ThisWorkbook.Worksheets("Control").Range("C5")
'set the target worksheet
With ThisWorkbook
Set wsTarget = .Sheets("Master Data")
Set bookName = .Sheets("Workbook Name")
End With
'set the initial output row and column count
'for master data and workbook name
nameCount = 2
Dim arTarget, rngSrc As Range, rngTarget As Range
Dim lastrow As Long, n As Long
With wsTarget
rowOutputTarget = 1 + .Cells(.Rows.Count, 1).End(xlUp).Row
' array of target column names
colCountTarget = .Cells(1, .Columns.Count).End(xlToLeft).Column
arTarget = .Cells(1, 1).Resize(, colCountTarget)
End With
'get the first file
strFile = Dir(strPath & "*.xlsx*")
'loop throught the excel files in the folder
Application.ScreenUpdating = False
Do While strFile <> ""
If InStr(strFile, fileName) > 0 Then
'open the workbook
Set wbSource = Workbooks.Open(strPath & strFile, ReadOnly:=True)
Set wsSource = wbSource.Worksheets("Details")
With wsSource
'get the row and column counts'get the row and column counts
colCountSource = .Cells(2, Columns.Count).End(xlToLeft).Column
Set srcRow = .Range("A2", .Cells(1, colCountSource))
' loop through target columns
For j = 1 To UBound(arTarget, 2)
Cr1 = arTarget(1, j)
Set found1 = srcRow.Find(What:=Cr1, LookAt:=xlPart, MatchCase:=True)
' found
If Not found1 Is Nothing Then
rowCountSource = .Cells(.Rows.Count, found1.Column).End(xlUp).Row
n = rowCountSource - 2
Set rngSrc = .Range(.Cells(3, found1.Column), .Cells(rowCountSource, found1.Column))
Set rngTarget = wsTarget.Cells(rowOutputTarget, j)
rngTarget.Resize(n).Value2 = rngSrc.Value2
If lastrow < rowOutputTarget + n Then
lastrow = rowOutputTarget + n
End If
End If
Next
End With
bookName.Range("A" & nameCount).Value = wbSource.Name
'update output row '2+12-1=13
nameCount = nameCount + 1
rowOutputTarget = lastrow
'close the opened workbook
wbSource.Close SaveChanges:=False
End If
'get the next file
strFile = Dir()
Loop
Application.ScreenUpdating = True
MsgBox "Data imported.", vbInformation, Format(Timer - t0, "0.0 secs")
End Sub
I have two questions but first a bit of background...
I have a number of workbooks each containing a different number of worksheets all saved in the same folder. Each worksheet except the first has an invoice from which I need data from specific cells copied on to the master sheet.
The Master sheet has 5 columns which will be populated with the information from the same 5 cells on each sheet on the following row.
Invoice Sheets Cell Master Sheet Row
E9 A
D18 B
D22 C
E11 D
F27 E
.
Sub Consolidate()
Dim wkbkorigin As Workbook
Dim originsheet As Worksheet
Dim destsheet As Worksheet
Dim ResultRow As Long
Dim Fname As String
Dim ColDest As String
Dim ColSrc As String
Dim RngDest As String
Dim RngSrc As String
Dim InvTotal As String
Dim RowInstructCrnt As Long
Dim RowSrcEnd As Long
Dim RowSrcStart As Long
Set destsheet = Workbooks("Test Master.xlsm").Worksheets("Sheet1")
'get list of all files in folder
Fname = Dir(ThisWorkbook.Path & "/*.xlsx")
'loop through each file in folder (excluding this one)
Do While Fname <> "" And Fname <> ThisWorkbook.Name
Set wkbkorigin = Workbooks.Open(ThisWorkbook.Path & "/" & Fname)
Set originsheet = wkbkorigin.Worksheets("Sheet1")
'find first empty row in destination table
ResultRow = destsheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
'start at top of list of cell references and work down until empty cell reached
Application.Goto ThisWorkbook.Worksheets("Sheet1").Range("D16")
With ThisWorkbook.Worksheets("Sheet1")
Do While Not IsEmpty(.Cells(16, 4))
ColSrc = .Cells(9, 5)
RowSrcStart = .Cells(18, 4)
RowSrcEnd = .Cells(22, 4)
ColDest = .Cells(11, 5)
InvTotal = .Cells(27, 6)
RngSrc = ColSrc & RowSrcStart & ColSrc & RowSrcEnd & InvTotal
RngDest = ColDest & ResultRow
originsheet.Range(RngSrc).Copy
destsheet.Range(RngDest).PasteSpecial
Loop
End With
Workbooks(Fname).Close SaveChanges:=False 'close current file
Fname = Dir 'get next file
Loop
End Sub
So my first question is - how can I modify this code to make it paste the correct information in the correct cells...
Secondly - I've not yet attempted looping through each sheet in the workbooks as I'm not sure where to begin...
Any advice would be greatly appreciated
Untested:
Sub Consolidate()
Dim wkbkorigin As Workbook
Dim originsheet As Worksheet
Dim destsheet As Worksheet
Dim ResultRow As Long
Dim Fname As String
Dim RngDest As Range
Set destsheet = ThisWorkbook.Worksheets("Sheet1")
Set RngDest = destsheet.Cells(Rows.Count, 1).End(xlUp) _
.Offset(1, 0).EntireRow
Fname = Dir(ThisWorkbook.Path & "/*.xlsx")
'loop through each file in folder (excluding this one)
Do While Fname <> "" And Fname <> ThisWorkbook.Name
If Fname <> ThisWorkbook.Name Then
Set wkbkorigin = Workbooks.Open(ThisWorkbook.Path & "/" & Fname)
Set originsheet = wkbkorigin.Worksheets("Sheet1")
With RngDest
.Cells(1).Value = originsheet.Range("E9").Value
.Cells(2).Value = originsheet.Range("D18").Value
.Cells(3).Value = originsheet.Range("D22").Value
.Cells(4).Value = originsheet.Range("E11").Value
.Cells(5).Value = originsheet.Range("F27").Value
End With
wkbkorigin.Close SaveChanges:=False 'close current file
Set RngDest = RngDest.Offset(1, 0)
End If
Fname = Dir() 'get next file
Loop
End Sub
Copying worksheets from multiple workbooks into current workbook
Hi I was wondering if anybody if you guys could help me out?
Im trying to copy multiple workbooks and just save it into only one worksheet.
I have 2000 diffrent workbooks with the diffrent amount of rows, The ammount of cells is the same and it dosent change and they are all at the first sheet in every workbook.
Im new with this kind of stuff so i'm thankfull for all help u can offer, I cant make it work. I'm using excel 2010
This is what I got atm:
Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow
Dim Filepath As String
Filepath = “C:\test\”
MyFile = Dir("test\")
Do While Len(MyFile) > 0
If MyFile = "master.xlsm" Then
Exit Sub
End If
Range(Range("a1"), ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Name = "PivotData"
Workbooks.Open (Filepath & MyFile)
Range("A2:AD20").Copy
ActiveWorkbook.Close
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("sheet1").Range(Cells(erow, 1), Cells(erow, 1))
MyFile = Dir
Loop End
Sub
I've re-written your code by applying what I posted in the comment.
Try this out: (I stick with your logic using the DIR function)
Sub test()
Dim MyFile As String, MyFiles As String, FilePath As String
Dim erow As Long
'~~> Put additional variable declaration
Dim wbMaster As Workbook, wbTemp As Workbook
Dim wsMaster As Worksheet, wsTemp As Worksheet
FilePath = "C:\test\"
MyFiles = "C:\test\*.xlsx"
MyFile = Dir(MyFiles)
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
'~~> Set your declared variables
Set wbMaster = ThisWorkbook 'if you want to consolidate files in this workbook
Set wsMaster = wbMaster.Sheets("Sheet1") 'replace Sheet1 to suit
Do While Len(MyFile) > 0
'Debug.Print MyFile
If MyFile <> "master.xlsm" Then
'~~> Open the file and at the same time, set your variable
Set wbTemp = Workbooks.Open(Filename:=FilePath & MyFile, ReadOnly:=True)
Set wsTemp = wbTemp.Sheets(1) 'I used index, you said there is only 1 sheet
'~~> Now directly work on your object
With wsMaster
erow = .Range("A" & .Rows.Count).End(xlUp).Row 'get the last row
'~~> Copy from the file you opened
wsTemp.Range("A2:AD20").Copy 'you said this is fixed as well
'~~> Paste on your master sheet
.Range("A" & erow).Offset(1, 0).PasteSpecial xlPasteValues
End With
'~~> Close the opened file
wbTemp.Close False 'set to false, because we opened it as read-only
Set wsTemp = Nothing
Set wbTemp = Nothing
End If
'~~> Load the new file
MyFile = Dir
Loop
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
I've commented the code to help you modify it to suit your needs.
I you got stuck again, then just go back here and clearly state your problem.
Try this out:
Option Explicit
Sub CombineDataFiles()
Dim DataBook As Workbook, OutBook As Workbook
Dim DataSheet As Worksheet, OutSheet As Worksheet
Dim TargetFiles As FileDialog
Dim MaxNumberFiles As Long, FileIdx As Long, _
LastDataRow As Long, LastDataCol As Long, _
HeaderRow As Long, LastOutRow As Long
Dim DataRng As Range, OutRng As Range
'initialize constants
MaxNumberFiles = 2001
HeaderRow = 1 'assume headers are always in row 1
LastOutRow = 1
'prompt user to select files
Set TargetFiles = Application.FileDialog(msoFileDialogOpen)
With TargetFiles
.AllowMultiSelect = True
.Title = "Multi-select target data files:"
.ButtonName = ""
.Filters.Clear
.Filters.Add ".xlsx files", "*.xlsx"
.Show
End With
'error trap - don't allow user to pick more than 2000 files
If TargetFiles.SelectedItems.Count > MaxNumberFiles Then
MsgBox ("Too many files selected, please pick more than " & MaxNumberFiles & ". Exiting sub...")
Exit Sub
End If
'set up the output workbook
Set OutBook = Workbooks.Add
Set OutSheet = OutBook.Sheets(1)
'loop through all files
For FileIdx = 1 To TargetFiles.SelectedItems.Count
'open the file and assign the workbook/worksheet
Set DataBook = Workbooks.Open(TargetFiles.SelectedItems(FileIdx))
Set DataSheet = DataBook.ActiveSheet
'identify row/column boundaries
LastDataRow = DataSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastDataCol = DataSheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
'if this is the first go-round, include the header
If FileIdx = 1 Then
Set DataRng = Range(DataSheet.Cells(HeaderRow, 1), DataSheet.Cells(LastDataRow, LastDataCol))
Set OutRng = Range(OutSheet.Cells(HeaderRow, 1), OutSheet.Cells(LastDataRow, LastDataCol))
'if this is NOT the first go-round, then skip the header
Else
Set DataRng = Range(DataSheet.Cells(HeaderRow + 1, 1), DataSheet.Cells(LastDataRow, LastDataCol))
Set OutRng = Range(OutSheet.Cells(LastOutRow + 1, 1), OutSheet.Cells(LastOutRow + 1 + LastDataRow, LastDataCol))
End If
'copy the data to the outbook
DataRng.Copy OutRng
'close the data book without saving
DataBook.Close False
'update the last outbook row
LastOutRow = OutSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Next FileIdx
'let the user know we're done!
MsgBox ("Combined " & TargetFiles.SelectedItems.Count & " files!")
End Sub