I have an excel sheet that in each cell in column A , the path of a source folder :
column A
P:\Desktop\Source\Test1-folder\file1.txt
P:\Desktop\Source\Test1-folder\file2.txt
and i want to take just the file name (file1.txt) for each file , how can i do it ? Can you help me please ?
For Each oFolder In oSourceFolder.SubFolders
lastcol = Cells(1, Cells.Columns.Count).End(xlToLeft).Column
For Each oFile In oFolder.Files
If Dir(destinationFolder, 16) = "" Then MkDir (destinationFolder)
For k = 1 To dercol
numrows = worksh.Cells(Rows.Count, icol).End(xlUp).Row
For w = 2 To numrows
filepath = worksh.Cells(w, icol).Value
But this one loops through the files, not the cells. How can I loop through the cells?
Try this:
' Get the sheet
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(1)
' How you will slash it
Dim strSlash As String
strSlash = "\"
' Set the range for your tool
Dim rngFiles As Range
Dim rngCell As Range
Dim lngMaxRow As Long
lngMaxRow = Range("A" & Rows.Count).End(xlUp).Row
Set rngFiles = Range("A1:A" & lngMaxRow)
' Grab it from the rear
For Each rngCell In rngFiles.Cells
Debug.Print Right(rngCell.Value, Len(rngCell.Value) - InStrRev(rngCell.Value, strSlash))
Next
If all you want is the file name, you can do this with a simple worksheet formula:
=TRIM(RIGHT(SUBSTITUTE(A1,"\",REPT(" ",99)),99))
Related
I would like to copy the data from one workbook to another.
My source workbook has some comments listed in each row. When I use my code to copy, it does not copy the comments accordingly. Could any one help, how I could copy from one workbook to another with the comment field ? my comments are in Column P.
Sub Extract()
Dim DestinationWB As Workbook
Dim OriginWB As Workbook
Dim path1 As String
Dim FileWithPath As String
Dim lastRow As Long, i As Long, LastCol As Long
Dim TheHeader As String
Dim cell As Range
Set DestinationWB = ThisWorkbook
path1 = DestinationWB.Path
FileWithPath = path1 & "\Downloads\CTT.xlsx"
Set OriginWB = Workbooks.Open(filename:=FileWithPath)
lastRow = OriginWB.Worksheets("Report").Cells(Rows.count, 1).End(xlUp).Row
LastCol = OriginWB.Worksheets("Report").Cells(22, Columns.count).End(xlToLeft).Column
For i = 1 To LastCol
'get the name of the field (names are in row 22)
TheHeader = OriginWB.Worksheets("Report").Cells(22, i).Value
With DestinationWB.Worksheets("CTT").Range("A4:P4")
'Find the name of the field (TheHeader) in the destination (in row 4)
Set cell = .Find(TheHeader, LookIn:=xlValues)
End With
If Not cell Is Nothing Then
OriginWB.Worksheets("Report").Range(Cells(23, i), Cells(lastRow, i)).Copy Destination:=DestinationWB.Worksheets("CTT").Cells(5, cell.Column)
Else
'handle the error
End If
Next i
OriginWB.Close SaveChanges:=False
End Sub
I refactored your code correcting the unqualified references and printing the Source and Destination range addresses to the Immediate window. This should give you an idea of what is going on.
Sub Extract()
Dim DestinationWB As Workbook
Dim OriginWB As Workbook
Dim FileWithPath As String, path1 As String, TheHeader As String
Dim lastRow As Long, col As Long
Dim cell As Range, Source As Range
Set DestinationWB = ThisWorkbook
path1 = DestinationWB.Path
FileWithPath = path1 & "\Downloads\CTT.xlsx"
Set OriginWB = Workbooks.Open(Filename:=FileWithPath)
With OriginWB.Worksheets("Report")
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For col = 1 To .Cells(22, .Columns.Count).End(xlToLeft).Column
'get the name of the field (names are in row 22)
TheHeader = OriginWB.Worksheets("Report").Cells(22, col).Value
With DestinationWB.Worksheets("CTT").Range("A4:P4")
'Find the name of the field (TheHeader) in the destination (in row 4)
Set cell = .Find(TheHeader, LookIn:=xlValues)
End With
If Not cell Is Nothing Then
Set Source = .Range(.Cells(23, col), .Cells(lastRow, col))
Source.Copy Destination:=cell.Offset(1)
Debug.Print Source.Address(External:=True), "Copied to ", cell.Offset(1).Address(External:=True)
Else
'handle the error
End If
Next
End With
OriginWB.Close SaveChanges:=False
End Sub
I am trying to copy data from one workbook to another.
my source workbook, contains data with 722 rows. but the code is copying only 72 rows.
While I was debugging, in siiurcewkbk, I could see 722 rows being selected but then in destwkb its just 72 rows being pasted.
also, the column in my sourcewb is in AK and I want them to be pasted in column A of destwb.
Could anyone help me to rectify this issue.
Sub Extract()
Dim x As Workbook
Dim y As Workbook
Dim Val As Variant
Dim filename As String
Dim LastCell As Range
Dim LastRow As Long
CopyCol = Split("AK", ",")
LR = Cells(Rows.Count, 1).End(xlUp).Row
LC = Cells(1, Columns.Count).End(xlToLeft).Column
LCell = Activewindow.RangeSelection.SpecialCells(xlCellTypeLastCell).Address
LCC = Activewindow.RangeSelection.SpecialCells(xlCellTypeLastCell).Column
lcr = Activewindow.RangeSelection.SpecialCells(xlCellTypeLastCell).Row
Set y = ThisWorkbook
Dim path1, Path2
path1 = ThisWorkbook.Path
Path2 = path1 & "\Downloads"
Set x = Workbooks.Open(filename:=Path2 & "\Red.xlsx")
For Count = 0 To UBound(CopyCol)
Set temp = Range(CopyCol(Count) & "1:" & CopyCol(Count) & lcr)
If Count = 0 Then
Set CopyRange = temp
Else
Set CopyRange = Union(CopyRange, temp)
End If
Next
CopyRange.Copy
y.Sheets("All").Paste y.Sheets("All").Range("A4")
Application.CutCopyMode = False
x.Close
End Sub
anylead would be helpful.
If you are just coping one column of data from one worksheet to another column in another worksheet there is a lot easier way of doing it.
Does the code below help? Sorry if I've misunderstood your requirements ...
Sub Extract()
Dim Path2 As String '** path to the workbook you want to copy to ***
Dim X As Workbook '*** WorkBook to copy from ****
Dim Y As Workbook '** WorkBook to copy to
Set X = ActiveWorkbook '** This workbook ****
Path2 = "C:\test" '** path of book to copy to
Set Y = Workbooks.Open(filename:=Path2 & "\Red.xlsx")
X.Sheets("From").Range("A:A").Copy Destination:=Y.Sheets("ALL").Range("A1")
Application.CutCopyMode = False
Y.Save
Y.Close
End Sub
Try this, I commented out some lines that were doing nothing as far as I can see because I'm strict about code. Also I added some Dim statements because I always write code with Option Explicit at the top of module, this is there to help the programmer as it traps hidden compile errors.
The solution to your problem is in the lines
Dim rngLastCell As Excel.Range
Set rngLastCell = Range(CopyCol(Count) & "65535").End(xlUp)
so what we're doing here is go to the last line of the sheet on row 65535 (I know later versions have more rows but this number is fine) and then we say End(xlUp) which logically means go up this column until you find some text which will be the bottom row of your block of data.
Just underneath I changed the syntax of the Range statement which is very flexible so one call Range with a string like Range("A1:B3") or one can call Range with two arguments each of them cells, so Range(Range("A1"),Range("B3")).
Option Explicit
Sub Extract()
Dim x As Workbook
Dim y As Workbook
Dim Val As Variant
Dim filename As String
Dim LastCell As Range
Dim LastRow As Long
Dim CopyCol
CopyCol = Split("AK", ",")
'* LR is never used
'LR = Cells(Rows.Count, 1).End(xlUp).Row
'* lc is never used
'lc = Cells(1, Columns.Count).End(xlToLeft).Column
'* LCell is never used
'LCell = ActiveWindow.RangeSelection.SpecialCells(xlCellTypeLastCell).Address
'* LCC is never used
'LCC = ActiveWindow.RangeSelection.SpecialCells(xlCellTypeLastCell).Column
Dim lcr
lcr = ActiveWindow.RangeSelection.SpecialCells(xlCellTypeLastCell).Row
Set y = ThisWorkbook
Dim path1, Path2
path1 = ThisWorkbook.Path
Path2 = path1 & "\Downloads"
Set x = Workbooks.Open(filename:=Path2 & "\Red.xlsx")
Dim Count As Long
For Count = 0 To UBound(CopyCol)
Dim rngLastCell As Excel.Range
Set rngLastCell = Range(CopyCol(Count) & "65535").End(xlUp)
Dim temp As Excel.Range
'Set temp = Range(CopyCol(Count) & "1:" & CopyCol(Count) & lcr)
Set temp = Range(CopyCol(Count) & "1", rngLastCell)
If Count = 0 Then
Dim CopyRange As Excel.Range
Set CopyRange = temp
Else
Set CopyRange = Union(CopyRange, temp)
End If
Next
CopyRange.Copy
y.Sheets("All").Paste y.Sheets("All").Range("A4")
Application.CutCopyMode = False
x.Close
End Sub
CopyCol = Split("AK", ",") is Array("AK")... why?
For Count = 0 To UBound(CopyCol) ... Next runs from 0 to 0 (one cycle).
to put it in an shorter sub, I recommend something like this:
Sub Extract()
Dim path1 As String
path1 = ThisWorkbook.Path & "\Downloads"
Dim CopyCol As String
CopyCol = "AK"
With Workbooks.Open(filename:=path1 & "\Red.xlsx")
With .ActiveSheet
.Range(.Cells(1, CopyCol), .Cells(.Rows.Count, CopyCol).End(xlUp)).Copy ThisWorkbook.Sheets("All").Range("A4")
End With
.Close
End With
End Sub
I have various workbooks with different employee names containing different projectnumbers and hours worked on these projects. I'm trying to get these project numbers filtered out to a master file (zmaster) containing the entire row(s) of a specific project number. I need Excel to filter through the directory (specific folder cointaining all employee hours files) for matches and copy these matches into the zmaster file. The filter is cell A1 of the master file (eg. 300000 in linked picture example). Picture 1 is the master file and picture 2 is an example of the employee hours file.
https://i.stack.imgur.com/OKs68.png (1)
https://i.stack.imgur.com/va2Yn.png (2)
Also, it would be great if Excel would filter out duplicates (eg. week 30 with the exact same hours and employee name already in the master file is most likely duplicate and should be ignored).
I'm pretty new to Excel vba and found/adjusted the following macro's. The first one copies all data from the directory and places it into the master file. The second one filters out the projectnumber matching with cell A1. However, this requires 2 steps and when I run my first macro for the second time it will also collect data already entered into the master file. Also, my second macro places matches in the same row number as where they're placed in the employee hours file and therefore removing earlier observations in the master file placed in the same row (eg. projectnumber 100000 is placed in row 2 of the employee hours file therefore copying to row 2 in the master file, removing the indicator row of the master file).
First macro:
Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow
Dim Filepath As String
Filepath = ("C:\test\”)
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "zmaster.xlsx" Then
Exit Sub
End If
Workbooks.Open (Filepath & MyFile)
Range("A2:L9").Copy
ActiveWorkbook.Close
erow = Blad1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(erow, 1), Cells(erow, 4))
MyFile = Dir
Loop
End Sub
Second macro:
Sub finddata()
Dim projectnumber As Integer
Dim finalrow As Integer
Dim i As Integer
Sheets("Blad1").Range("A1:H9").ClearContents
projectnumber = Sheets("Blad1").Range("A1").Value
finalrow = Sheets("Blad1").Range("A30").End(x1Up).row
For i = 1 To finalrow
If Cells(i, 1) = projectnumber Then
Range(Cells(i, 1), Cells(i, 12)).Copy
Range("A100").End(x1Up).Offset(1, 0).PasteSpecial x1pasteformulasandnumberformats
End If
Next i
Range("A1").Select
End sub
Hopefully everything is clear and thanks in advance!
This should work.
Open each file in directory
check that the file name is not zmaster and that it contains xlsx
run through each row in the current file and then combine the range for copying to master file
copy to master file last row plus 1, which is the first empty row
Option Explicit
Sub CopyToMasterFile()
Dim MasterWB As Workbook
Dim MasterSht As Worksheet
Dim MasterWBShtLstRw As Long
Dim FolderPath As String
Dim TempFile
Dim CurrentWB As Workbook
Dim CurrentWBSht As Worksheet
Dim CurrentShtLstRw As Long
Dim CurrentShtRowRef As Long
Dim CopyRange As Range
Dim ProjectNumber As String
FolderPath = "C:\test\"
TempFile = Dir(FolderPath)
Dim WkBk As Workbook
Dim WkBkIsOpen As Boolean
'Check is zmaster is open already
For Each WkBk In Workbooks
If WkBk.Name = "zmaster.xlsx" Then WkBkIsOpen = True
Next WkBk
If WkBkIsOpen Then
Set MasterWB = Workbooks("zmaster.xlsx")
Set MasterSht = MasterWB.Sheets("Blad1")
Else
Set MasterWB = Workbooks.Open(FolderPath & "zmaster.xlsx")
Set MasterSht = MasterWB.Sheets("Blad1")
End If
ProjectNumber = MasterSht.Cells(1, 1).Value
Do While Len(TempFile) > 0
'Checking that the file is not the master and that it is a xlsx
If Not TempFile = "zmaster.xlsx" And InStr(1, TempFile, "xlsx", vbTextCompare) Then
Set CopyRange = Nothing
'Note this is the last used Row, next empty row will be this plus 1
With MasterSht
MasterWBShtLstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Set CurrentWB = Workbooks.Open(FolderPath & TempFile)
Set CurrentWBSht = CurrentWB.Sheets("Sheet1")
With CurrentWBSht
CurrentShtLstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For CurrentShtRowRef = 1 To CurrentShtLstRw
If CurrentWBSht.Cells(CurrentShtRowRef, "A").Value = ProjectNumber Then
'This is set to copy from Column A to Column L as per the question
If CopyRange Is Nothing Then
'If there is nothing in Copy range then union wont work
'so first row of the work sheet needs to set the initial copyrange
Set CopyRange = CurrentWBSht.Range("A" & CurrentShtRowRef & _
":L" & CurrentShtRowRef)
Else
'Union is quicker to be able to copy from the sheet once
Set CopyRange = Union(CopyRange, _
CurrentWBSht.Range("A" & CurrentShtRowRef & _
":L" & CurrentShtRowRef))
End If ' ending If CopyRange Is Nothing ....
End If ' ending If CurrentWBSht.Cells....
Next CurrentShtRowRef
CopyRange.Select
'add 1 to the master file last row to be the next open row
CopyRange.Copy MasterSht.Cells(MasterWBShtLstRw + 1, 1)
CurrentWB.Close savechanges:=False
End If 'ending If Not TempFile = "zmaster.xlsx" And ....
TempFile = Dir
Loop
End Sub
I have an excel file in drive "D".I would like to copy the data from workbook
"raw" from sheet1 to the another workbook "SC" in sheet "BW".
I am using the below code, to extract the data from one workbook and pasting it to another.
Sub extract()
Dim x As Workbook
Dim y As Workbook
Dim Val As Variant
Dim filename As String
Dim LastCell As Range
Dim LastRow As Long
CopyCol = Split("A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X", ",")
LR = Cells(Rows.Count, 1).End(xlUp).Row
LC = Cells(1, Columns.Count).End(xlToLeft).Column
LCell = Selection.SpecialCells(xlCellTypeLastCell).Address
LCC = Selection.SpecialCells(xlCellTypeLastCell).Column
LCR = Selection.SpecialCells(xlCellTypeLastCell).Row
Set y = ThisWorkbook ' set ThisWorkbook object (where this code lies)
Set x = Workbooks.Open("D:\Student\Jenny\Raw.xlsx")
For Count = 0 To UBound(CopyCol)
Set temp = Range(CopyCol(Count) & "1:" & CopyCol(Count) & LCR)
If Count = 0 Then
Set CopyRange = temp
Else
Set CopyRange = Union(CopyRange, temp)
End If
Next
CopyRange.Copy
y.Sheets("BW").Range("A5").PasteSpecial
x.Close
End Sub
This code is workin, but the problem is , in my sheet "sheet1" I have my data starting from A4, and would like to copy the data in destination sheet "BW" from A5.
The current code, paste the copied data from A7. How can I modify such a way that it pastes the copied data from A5.
Any lead would be helpful.
In Set temp try 4 instead of 1 as
Set temp = Range(CopyCol(Count) & "1:" & CopyCol(Count) & LCR)
How I can select an particular sheet (Sheet Result) from source sheet. ?
Use
With x.Sheets("Result")
.
.
.
End With
or
x.Sheets("Result"). or whatever you are trying.
You have many unused and undeclared variables. Your updated code may look something like this:
Option Explicit
Sub extract()
Dim x As Workbook, y As Workbook
Dim temp As Range, CopyRange As Range
Dim LR As Long, LC As Long, LCR As Long, Count As Long
Dim copycol
copycol = Split("A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X", ",")
LR = Cells(Rows.Count, 1).End(xlUp).Row
LC = Cells(1, Columns.Count).End(xlToLeft).Column
Set y = ThisWorkbook ' set ThisWorkbook object (where this code lies)
Set x = Workbooks.Open("D:\Student\Jenny\Raw.xlsx")
With x.Sheets("Result")
LCR = .Cells(.Rows.Count, 1).End(xlUp).Row
For Count = 0 To UBound(copycol)
Set temp = .Range(copycol(Count) & "4:" & copycol(Count) & LCR)
If Count = 0 Then
Set CopyRange = temp
Else
Set CopyRange = Union(CopyRange, temp)
End If
Next
CopyRange.Copy
y.Sheets("BW").Range("A5").PasteSpecial
End With
x.Close
End Sub
I am able to copy the last row of one workbook and paste it after the last row of another workbook. I want to copy the entire data from row 2 (row 1 is header) in the first workbook and paste it after the last row of another workbook. Please advise me what changes are required in the code below to copy the entire data from row 2 instead of only the last row.
Dim lastS1Row As Long
Dim nextS2Row As Long
Dim lastCol As Long
Dim lCol As Long
Dim lCol1 As Long
Dim s1Sheet As Worksheet, s2Sheet As Worksheet
Dim source As String
Dim target As String
Dim path As String
Dim path1 As String
source = "Students" 'Source Worksheet Name
path1 = "H:\Shaikh_Gaus\scratch\VBA\Book17.xlsx"
path = "H:\Shaikh_Gaus\scratch\VBA\Book16.xlsx"
target = "Students" 'Target Worksheet Name
Application.EnableCancelKey = xlDisabled
Set s1Sheet = Workbooks.Open(path).Sheets(source)
Set s2Sheet = Workbooks.Open(path1).Sheets(target)
lastS1Row = s1Sheet.Range("A" & Rows.Count).End(xlUp).Row
nextS2Row = s2Sheet.Range("A" & Rows.Count).End(xlUp).Row + 1
lastCol = s1Sheet.Cells(1, Columns.Count).End(xlToLeft).Column
For lCol = 1 To lastCol
s2Sheet.Cells(nextS2Row, lCol) = s1Sheet.Cells(lastS1Row, lCol)
Next lCol
Next lCol1
s2Sheet.Activate
ActiveWorkbook.Close SaveChanges:=True
s1Sheet.Activate
ActiveWorkbook.Close
This adjusted version of your code should do the job:
Dim s1Sheet As Worksheet, s2Sheet As Worksheet
Dim source As String
Dim target As String
Dim path As String
Dim path1 As String
Dim rngSource As Range
Dim rngTargetStart As Range
source = "Students" 'Source Worksheet Name
path1 = "H:\Shaikh_Gaus\scratch\VBA\Book17.xlsx"
path = "H:\Shaikh_Gaus\scratch\VBA\Book16.xlsx"
target = "Students" 'Target Worksheet Name
Application.EnableCancelKey = xlDisabled
Set s1Sheet = Workbooks.Open(path).Sheets(source)
Set s2Sheet = Workbooks.Open(path1).Sheets(target)
Set rngSource = Range(s1Sheet.Range("A2"), s1Sheet.Cells.SpecialCells(xlCellTypeLastCell))
Set rngTargetStart = s2Sheet.Range("A" & Rows.Count).End(xlUp).Offset(1)
rngTargetStart.Resize(rngSource.Rows.Count, rngSource.Columns.Count).Value = rngSource.Value
s2Sheet.Parent.Close SaveChanges:=True
s1Sheet.Parent.Close
I removed something what seemed unnecessary. The main thing is that now you don't loop through columns and rows. Now you can do it with one operation.
Avoid as much as you can things like .Select, .Activate. and .Copy if you just need values to be pasted. You can simply do something similar like I did:
Target.Value = Source.Value
After you set s1Sheet and s2Sheet I think you should be able to use these 2 lines to copy & paste the entire range at once:
'copy Cells A2 through last row and last column used
s1Sheet.Range(s1Sheet.Cells(2, 1), s1Sheet.Cells(s1Sheet.Cells(s1Sheet.Rows.Count, 1).End(xlUp).Row, _
s1Sheet.Cells(1, s1Sheet.Columns.Count).End(xlToLeft).Column)).Copy
'paste those cells in next blank row of second sheet
s2Sheet.Cells(s2Sheet.Cells(s2Sheet.Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial Paste:=xlPasteAll
'Here you go:
Range("A2").End(xlDown).select
selection.End(xlRight).select
selection.copy
'then active the next sheet for e.g Sheet2.Active
last_row = range("A1048576").end(xlup).row
range("A" & last_row).paste
' Done