I am trying to consolidate data from a list of file paths into one worksheet then add the names per dataset. I have a list of names and paths set up like this in Excel:
Name1, Path1
Name2, Path2
Name3, Path3
The macro I have written so far loops through the paths, copy and paste into the master spreadsheet starting in the first empty in column B. What I want the macro to also do is also fill in column A with Name1, Name2, and Name3 next to the respective dataset. I got the macro do to the first part but now I can't get it to do the naming part. Here is my code so far:
Sub Data()
Dim ws As Worksheet, dataws As Worksheet
Dim wkb As Workbook, wkbFrom As Workbook
Dim wkblist As Range
Dim fromtab As String
Dim Name As String
For Each wkblist In Sheets("Ref").Range("d4:d18")
If wkblist.Value = "" Then
Exit For
Else
Set wkb = ThisWorkbook
Set wkbFrom = Workbooks.Open(wkblist)
Set ws = wkb.Sheets("Ref")
Set dataws = wkb.Sheets("Data")
fromtab = ws.Range("b22")
wkbFrom.Worksheets(fromtab).Range("b2:z200").Copy
dataws.Cells(Rows.Count, 5).End(xlUp).Offset(1).PasteSpecial xlValues
Application.CutCopyMode = False
wkbFrom.Close
End If
Next wkblist
End Sub
Ta,
I'm not too sure what worksheet you want the names to be pasted; I assume the data WS in the code below. Also, I would set the wkb, ws, and dataws outside of the loop since they are or belong to "ThisWorkbook". Not that it hurts to be inside of the loop, but you're just resetting them each time the loop runs.
The code below should find the range of rows that you just pasted into dataws. Then, it copies the names that are related to the wkblist in Col C into Col A of dataws.
Dim colARow, colBRow As Long
' Place code below after you paste the paths into Col B of the worksheet
' Find first blank in Col A
colARow = dataws.Cells(Rows.Count, 1).End(xlUp).Row + 1
' Find last filled cell in Col B
colBRow = dataws.Cells(Rows.Count, 2).End(xlUp).Row
dataws.Range("A" & colARow & ":A" & colBRow).Value = wkblist.Offset(0,-1).Value
Related
The goal is to use a reference Excel workbook as a database to find matching BoxID and then copy cells D to G in the same row. Finally pasting to another workbook that consists of a single worksheet.
I figured Xlookup would be easiest. In Excel it works but it doesn't in VBA.
Three main questions
How do I open another workbook and then reference all sheets or a specific range through all sheets in a dynamically named workbook to my current activeworkbook?
(e.g. sheets will be named freezer 23, freezer 43, fridge 190 in database.)
The rows of the sheets is variable but the columns stay the same.
Is there a way to do the above but if nothing is found to leave the cell blank?
Is there a way I could simplify this code?
On the left is the database which is going to be the external reference/where the data is coming from and on the right is the output sheet. Where I will be using Xlookup to search for the matching value. column "A" is where the search value will be and output to the next 4 cells.
Sub FreezerPulls()
Dim lastrow, j As Long
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
Dim a As Integer
Dim list As Workbook
Dim frzdatabase As
Dim BoxIDlist, info, BoxIDdatabase, database, databasepath As String
databasepath = ("C:\Users\mikeo\Desktop\DataBaseStandard.xlsm")
Workbooks.Open ("C:\Users\mikeo\Desktop\DataBaseStandard.xlsm")
database = "DataBaseStandard.xlsm"
Set list = ThisWorkbook
list.Activate
Set BoxIDlist = Worksheets("Sheet1").Range("A" & Row.Count).End(xlUp).Row 'emphasized textthis doesn't work
Set BoxIDdatabase = Range("A2:A1500")
Set info = Range("D2:G1500")
a = Application.Worksheets.Count
End Sub
You could do something like this, using Match(). See comments in code
Sub FreezerPulls()
Const DB_PATH As String = "C:\Users\mikeo\Desktop\DataBaseStandard.xlsm"
Dim wbData As Workbook, ws As Worksheet, rw As Range, id, m
Set wbData = Workbooks.Open(DB_PATH, ReadOnly:=True) 'get a reference to the data workbook
'loop each row in the lookup table
For Each rw In ThisWorkbook.Sheets("Sheet1").Range("A17:F40").Rows
id = rw.Cells(1).Value 'Box ID to find
If Len(id) > 0 Then 'any value to look up?
For Each ws In wbData.Worksheets 'loop all worksheets in data workbook
m = Application.Match(id, ws.Columns("A"), 0) 'any match on this sheet ColA?
If Not IsError(m) Then 'no error = match was made on row m
rw.Cells(3).Value = ws.Name 'add freezer name
rw.Cells(4).Resize(1, 3).Value = _
ws.Cells(m, 5).Resize(1, 3).Value 'copy segment, rackID, position
Exit For 'done searching (assumes box id's are unique)
End If
Next ws
End If
Next rw
wbData.Close False
End Sub
I know this topic has been asked about before but nothing quite covers what I need. So here's the thing..
I have two workbooks. One is exported from another program which shows a staff member's Surname, first name, email and which ward they work on.
[Workbook1 example]
The second is the full staff list which has the same details but also a check list column.
[Workbook2 example]
What I need is a macro (probably a vlookup) which takes the information from the workbook1, checks against surname, first name and ward on workbook2 to ensure that it is the correct member of staff, copies the email onto workbook 2 and also fills the checklist column on workbook 2 to "Yes".
I'm afraid I am at a loss as to how to incorporate all of this together. Please help.
This is what I have so far but my knowledge is limited and did not know how to proceed.
Private Sub UpdateTraining_Click()
Dim I As Integer
Dim Ws1 As Worksheet
Dim Ws2 As Worksheet
Dim Ws3 As Worksheet
Dim Wb As Workbook
Dim CopyData As String
Dim RwCnt As Long
Dim RwCnt2 As Long
Dim Rw As Long
Dim Clm As Long
Dim SName As String
Dim FName As String
Dim Wrd As String
Dim vArr
Dim ClmLet As String
Set Ws1 = Workbooks("Nursing Docs Training Record.xlsm").Worksheets("Staff Training Record")
Set Ws2 = Workbooks("Nursing Docs Training Record.xlsm").Worksheets("Do Not Use")
Workbooks.Open ("C:\TypeformNursingDocumentation.xlsx")
Set Ws3 = Workbooks("TypeformNursingDocumentation.xlsx").Worksheets("tWeXNp")
RwCnt = Ws3.Cells(Rows.Count, 1).End(xlUp).Row
RwCnt2 = Ws1.Cells(Rows.Count, 1).End(xlUp).Row
Rw = Ws3.Range("F2").Row
Clm = Ws3.Range("F2").Column
Table1 = Ws3.Range("F2:F" & RwCnt)
vArr = Split(Cells(1, Clm).Address(True, False), "$")
ClmLet = vArr(0)
For Each cl In Table1
Ws3.Range(ClmLet & Rw).Select
SName = ActiveCell.Value
FName = ActiveCell.Offset(0, -1).Value
Wrd = ActiveCell.Offset(0, -4).Value
Rw = Rw + 1
Next cl
End Sub
You can achieve this with formulas but then you have to open Workbook1 for the formulas to work in Workbook2. So below approach uses VBA to achieve the results
Copy the below UDF in a module in Workbook2:
Sub UpdateMyList()
Dim oSourceWB As Workbook
Dim oSourceR As Variant
Dim iTotSRows&, iTotCRows&, iCC&, iSC&
Dim oCurR As Variant
Application.ScreenUpdating = False
' First lets get source data
Set oSourceWB = Workbooks.Open("C:\Temp\EmpLookup.xlsx", ReadOnly:=True) ' Change the source file name
With oSourceWB.Worksheets("Sheet1") ' Change the source sheet name
iTotSRows = .Range("A" & .Rows.count).End(xlUp).Row
oSourceR = .Range("A2:G" & iTotSRows)
End With
oSourceWB.Close False
' We now need the data from the sheet in this workbook to compare against
With ThisWorkbook.Worksheets("Sheet8") ' Change the sheet name to the sheet in your workbook
iTotCRows = .Range("A" & .Rows.count).End(xlUp).Row
oCurR = .Range("A2:H" & iTotCRows)
End With
' Next, lets compare and update fields
For iCC = 1 To UBound(oCurR)
For iSC = 1 To UBound(oSourceR)
If (oCurR(iCC, 1) = oSourceR(iSC, 6)) And (oCurR(iCC, 2) = oSourceR(iSC, 5)) And (oCurR(iCC, 5) = oSourceR(iSC, 2)) Then
oCurR(iCC, 7) = oSourceR(iSC, 7)
oCurR(iCC, 8) = "Yes"
Exit For
End If
Next
Next
Application.ScreenUpdating = True
' Finally, lets update the sheet
ThisWorkbook.Worksheets("Sheet8").Range("A2:H" & iTotCRows) = oCurR
End Sub
I've commented on the lines where you need to change references to workbook or worksheets. As long as you have updated the workbook and worksheet references, this should give you the desired results
I built the above UDF based on the columns as you provided in your question. If the columns change, you will have to modify the UDF or get the columns dynamically
You can use and If(Countif()) style function, where the countif checks for the presence of your value, and the if will return true if it is a match, then you can use the if true / false values accordingly. Let me know if you need more details but it could look something like this =IF(COUNTIF(The selected cell is in the selected range),"Yes", "No"). Then record this as a macro and copy the code into yours.
I have run through the relevant topics on the Internet, however I cannot find a solution to the problem I have encountered. I am working on a macro which would copy relevant data from one workbook into a newly created sheet in another workbook and then loop through the remaining worksheets of the latter to find exact matches to the data in this newly created sheet. The part in which I copy and paste the data works fine, however, when it comes to looping through worksheets an error occurs.
I worked up multiple versions of this macro to see whether different solutions would work, however, actually none seems to work. I the destination workbook, the worksheet contain data tickers (sort of an id) in column A, the measure of data relevance in column B and names of the variables in column C.
What I am trying to do is, after copying and pasting the data to a newly created sheet - where the data tickers are contained in column L, loop through all the default sheets in the destination workbook to check whether the tickers in column L of the newly created sheet overlap with the tickers in column A of the remainig worksheets, and, if so, copy the variable name from column C of the relevant worksheet into the newly created worksheet column M. The newly created worksheet is called "Settings" and contains headers in row 1 (it also consists of about 110 rows), the remaining worksheets contain no headers (and have 70 rows maximum).
The macro looks like this:
Sub match1()
Dim listwb As Workbook, mainwb As Workbook
Dim FolderPath As String
Dim fname As String
Dim sht As Worksheet
Dim ws As Worksheet, oput As Worksheet
Dim oldRow As Integer
Dim Rng As Range
Dim ws2Row As Long
Set mainwb = Application.ThisWorkbook
With mainwb
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Settings"
Set oput = Sheets("Settings")
End With
FolderPath = "C:\VBA\"
fname = Dir(FolderPath & "spr.xlsx")
With Application
Set listwb = .Workbooks.Open(FolderPath & fname)
End With
Set sht = listwb.Worksheets(1)
With sht
.UsedRange.Copy
End With
mainwb.Activate
With oput
.Range("A1").PasteSpecial
End With
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Settings" Then
ws2Row = ws.Range("A" & Rows.Count).End(xlUp).Row
Set Rng = ws.Range("A:C" & ws2Row)
For oldRow = 2 To 110
Worksheets("Settings").Cells(oldRow, 13) = Application.WorksheetFunction.IfError(Application.WorksheetFunction.VLookup(Worksheets("Settings").Cells(oldRow, 12), Rng, 3, False), "")
Next oldRow
End If
Next ws
End Sub
Alternative version looks like this (skipping the copy-paste part):
mainwb.Activate
With oput
.Range("A1").PasteSpecial
End With
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Settings" Then
i = 1
For oldRow = 2 To 110
For newRow = 1 To 70
If StrComp((Worksheets("Settings").Cells(oldRow, 12).Text), (ws.Cells(newRow, 1).Text), vbTextCompare) <> 0 Then
i = oldRow
Worksheets("Settings").Cells(i, 13) = " "
Else
Worksheets("Settings").Cells(i, 13) = ws.Cells(newRow, 3)
i = i + 1
Exit For
End If
Next newRow
Next oldRow
End If
Next ws
When I launch the first version of the macro I get an error:
Run-time error '1004':
Method 'Range' of object '_Worksheet' failed
Debugging highlights the part:
Set Rng = ws.Range("A:C" & ws2Row)
When I run the second version of the macro the error message reads:
Run-time error '9':
Subscript out of range
Debugging highlights the part:
If StrComp((Worksheets("Settings").Cells(oldRow, 12).Text), (ws.Cells(newRow, 1).Text), vbTextCompare) <> 0 Then
I suspect the problem is the definition and use of the ws (Worksheet) object. I am confused now because I use VBA a lot and I've done tasks much harder than this one. And yet I still can't solve the problem. Could you please suggest some solution. I will appreciate your help.
In this line: Set Rng = ws.Range("A:C" & ws2Row) you do not indicate a row value for Column A. Your code basically says Range("A:C110"), which doesn't really mean anything to Excel. Try changing it to Range("A2:C" & ws2Row).
Does that fix the problem?
I would be extremely grateful for any help as I have just begun to look into writing Excel macros.
I have excel documents with about 1,500 rows and variable column lengths, from 16-18. I would like to write each row of the file to a new .txt file (actually, I would REALLY like to write it as a .pdf but I don't think that's possible) where the name of the file is the corresponding first column. Additionally, I would like each row to be separated by a new line. So, ideally, the macro would 1) export each row as a new .txt file (or .pdf if possible), 2) name each file as ColumnA, 3) the content of each new .txt file would contain ColumnsB-length of total columns 4) each column is separated by a new line.
For example, if the document looks like this:
column 1//column 2// column3
a//a1//a2
b//b1//b2
I want it to output to be 2 files, named "a", "b". As an example, the contents of file "a" would be:
a1
a2
I have found 2 other stack overflow threads addressing separate pieces of my question, but I am at a loss as to how to stitch them together.
Each row to new .txt file, with a newline between each column (but file name not ColumnA):
Create text Files from every row in an Excel spreadsheet
Only one column incorporated into file, but file names correspond with ColumnA:
Outputting Excel rows to a series of text files
Thank you for any help!
To get the contents to be columns B thru the end of the file, you could do something like this.
Create a simple loop over the cells in Column B. This defines a range of columns for each row, and also sets a filename based on the value in column A.
Sub LoopOverColumnB()
Dim filePath as String
Dim fileName as String
Dim rowRange as Range
Dim cell as Range
filePath = "C:\Test\" '<--- Modify this for your needs.
For each cell in Range("B1",Range("B1048576").End(xlUp))
Set rowRange = Range(cell.address,Range(cell.address).End(xlToRight))
fileName = filePath & cell.Offset(0,-1).Value
'
' Insert code to write the text file here
'
' you will be able to use the variable "fileName" when exporting the file
Next
End Sub
I ended up stitching the following together to solve my problem, thanks entirely to #David and #Exactabox. It is incredibly inefficient and has redundant bits, but it runs (Very. Slowly). If anyone can spot how to clean it up, feel free, but otherwise it gets the job done.
[edit] Unfortunately I now realize that although this macro exports each row as an appropriately named new .txt file, the content of each text file is the last row of the document. So even if it exports all 20 lines as 20 .txt files with an appropriate file name and correct formatting, the actual content of each of the 20 files is the same. I am unsure how to rectify this.
Sub SaveRowsAsTXT()
Dim wb As Excel.Workbook, wbNew As Excel.Workbook
Dim wsSource As Excel.Worksheet, wsTemp As Excel.Worksheet
Dim r As Long, c As Long
Dim filePath As String
Dim fileName As String
Dim rowRange As Range
Dim cell As Range
filePath = "C:\filepath\"
For Each cell In Range("B1", Range("B1048576").End(xlUp))
Set rowRange = Range(cell.Address, Range(cell.Address).End(xlToRight))
fileName = filePath & cell.Offset(0, -1).Value
Set wsSource = ThisWorkbook.Worksheets("Sheet1")
Application.DisplayAlerts = False 'will overwrite existing files without asking
r = 1
Do Until Len(Trim(wsSource.Cells(r, 1).Value)) = 0
ThisWorkbook.Worksheets.Add ThisWorkbook.Worksheets(1)
Set wsTemp = ThisWorkbook.Worksheets(1)
For c = 2 To 16
wsTemp.Cells((c - 1) * 2 - 1, 1).Value = wsSource.Cells(r, c).Value
Next c
wsTemp.Move
Set wbNew = ActiveWorkbook
Set wsTemp = wbNew.Worksheets(1)
wbNew.SaveAs fileName & ".txt", xlTextWindows 'save as .txt
wbNew.Close
ThisWorkbook.Activate
r = r + 1
Loop
Application.DisplayAlerts = True
Next
End Sub
This should fix the problem of getting the same data in all the files:
Sub SaveRowsAsTXT()
Dim wb As Excel.Workbook, wbNew As Excel.Workbook
Dim wsSource As Excel.Worksheet, wsTemp As Excel.Worksheet
Dim r As Long, c As Long
Dim filePath As String
Dim fileName As String
Dim rowRange As Range
Dim cell As Range
filePath = "C:\Users\Administrator\Documents\TEST\"
For Each cell In Range("B1", Range("B10").End(xlUp))
Set rowRange = Range(cell.Address, Range(cell.Address).End(xlToRight))
Set wsSource = ThisWorkbook.Worksheets("Sheet1")
Application.DisplayAlerts = False 'will overwrite existing files without asking
r = 1
Do Until Len(Trim(wsSource.Cells(r, 1).Value)) = 0
ThisWorkbook.Worksheets.Add ThisWorkbook.Worksheets(1)
Set wsTemp = ThisWorkbook.Worksheets(1)
For c = 2 To 16
wsTemp.Cells((c - 1) * 2 - 1, 1).Value = wsSource.Cells(r, c).Value
Next c
fileName = filePath & wsSource.Cells(r, 1).Value
wsTemp.Move
Set wbNew = ActiveWorkbook
Set wsTemp = wbNew.Worksheets(1)
wbNew.SaveAs fileName & ".txt", xlTextWindows 'save as .txt
wbNew.Close
ThisWorkbook.Activate
r = r + 1
Loop
Application.DisplayAlerts = True
Next
End Sub
#danfo, I don't know if this will be useful to you, but after some fiddling, I did get this working. I needed to make sure that all my top row was written with no spaces or special characters; and my left column needed to be ID numbers, rather than dates or anything else -- but once I'd fixed those things, it worked fine.
I have an Excel spreadsheet with many tabs. I'd like to export the last column of each sheet in a text file (all in the same file, the first line of the second sheet must go just after the last line of the fist sheet).
The thing is the number of columns changes from one sheet to another. The number of the last column can be given by the last non empty cell on the first row.
I've seen how to write in a file, but I'm clueless on how to iterate over sheets and rows...
Any help is welcome. Thanks.
You can find the last cell in a row using this code:
Sub LastCellInRow()
Range("IV1").End(xlToLeft).Select
End Sub
You can iterate through every Worsheet using the Worksheets collection:
Sub LoopThroughSheets()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
'** Perform code here **
Next ws
End Sub
This works:
Dim r As Range
Dim s As Worksheet
Dim wbSource As Workbook
Dim wbDestination As Workbook
Dim lastcol As Long
Dim lastrow As Long
Dim cumrow As Long
Dim i As Long
Set wbSource = ActiveWorkbook
Set wbDestination = Workbooks.Open("C:\destination.xls")
cumrow = 0
For Each s In wbSource.Worksheets
lastcol = s.Cells(1, s.Columns.Count).End(xlToLeft).Column
lastrow = s.Cells(s.Rows.Count, lastcol).End(xlUp).Row
Set r = s.Cells(1, lastcol).Resize(lastrow, 1) ' This is your column
' Copy it to appropriate location on destination sheet
wbDestination.Sheets(1).Cells(cumrow + 1, 1).Resize(lastrow, 1) = r
cumrow = cumrow + lastrow
Next s
The above was written and tested while on a video conference call!