I am somewhat new to VBA/Excel, so I was wondering if someone would help me out.
My question:
I have two different workbooks but in these workbooks two of the columns have common data. Thus I wanted to use VLOOKUP to compare the two columns and see if there are common data.
Details:
1st workbook : has 3 different sheets, I only need to use the sheet "Items" which has the data in column 2.
2nd workbook: has only 1 sheet called "Data" and has data in column 4.
Thus my goal is to compare the 2 columns. In workbook1 there is an empty column next to the data column so, if there is a match I want to say "ok" in it. If no match then "".
I tried VLOOKUP but really could not understand it. Plus this is for work.
You may try this..
Assuming the name of your second workbook is Book2.xlsx, then try this...
On First workbook
In C2
=IF(ISNUMBER(MATCH(B2,'[Book2.xlsx]Data'!$D:$D,0)),"OK","")
and copy it down.
If you require a VBA solution, one approach to get the desired output is as below...
The following code assumes that both the Book1.xlsm (which will contain the below code) and Book2.xlsx are saved in the same folder.
If they are saved at different location, change the path and name of Book2.xlsx in the following lines of code.
sourceFilePath = dwb.Path & "\"
sourceFileName = "Book2.xlsx"
Code:
Sub CompareData()
Dim swb As Workbook, dwb As Workbook
Dim sws As Worksheet, dws As Worksheet
Dim slr As Long, dlr As Long, i As Long
Dim sourceFilePath As String, sourceFileName As String
Dim x, y, z, dict
Application.ScreenUpdating = False
Set dwb = ThisWorkbook
Set dws = dwb.Sheets("Items")
dlr = dws.Cells(Rows.Count, 2).End(xlUp).Row
x = dws.Range("B2:B" & dlr).Value
ReDim z(1 To dlr)
sourceFilePath = dwb.Path & "\"
sourceFileName = "Book2.xlsx"
Workbooks.Open sourceFilePath & sourceFileName
Set swb = ActiveWorkbook
Set sws = swb.Sheets("Data")
slr = sws.Cells(Rows.Count, 4).End(xlUp).Row
y = sws.Range("D2:D" & slr).Value
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(y, 1)
dict.Item(y(i, 1)) = ""
Next i
swb.Close False
For i = 1 To UBound(x, 1)
If dict.exists(x(i, 1)) Then
z(i) = "OK"
Else
z(i) = ""
End If
Next i
dws.Range("C2").Resize(UBound(x, 1), 1).Value = Application.Transpose(z)
Application.ScreenUpdating = True
End Sub
Related
I have an excel sheet which looks like this - All the data is numerical data. The actual sheet has a lot more rows & columns in reality.
https://i.imgur.com/E2HEdXF.png
What I Want to get out of this data is something like this - For each year, I want to sort A & F based on the year's numerical data. So not one sort, but one sort per year.
I don't think there is a simple method for doing this, so I was thinking of 2 possible ways
I export the data into some database & then use SQL queries to get the output I want - I assume there must be some databases which allow you import Excel data.
or
Write a VBA program which does the following - Copy Column D & E into another place & sort based on Column E. Then Copy Column D & F into another place & sort based on Column F & so on & so forth.
I have never done VBA, but I am programmer, so I assume it wouldn't be trouble to do this.
However, I was wondering if there is some other easier way to do it or if not, which of the above two would be a better way to do it.
Copy and Sort
The following will copy the data from columns D:G as column pairs consisting of the first column and each next column, to columns A:B of newly created worksheets of the workbook containing this code and finally sort them descendingly by column B. Already existing worksheets, to be created, will previously be deleted.
Adjust the values in the constants section.
Option Explicit
Sub copyAndSort()
Const sName As String = "Sheet1"
Const sFirst As String = "D1"
Const yCols As String = "E:G"
Const dFirst As String = "A1"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim srg As Range
Dim yrg As Range
Dim rCount As Long
Dim cCount As Long
With sws.Range(sFirst)
Dim rOff As Long: rOff = .Row - 1
Dim sCell As Range
Set sCell = .Resize(.Worksheet.Rows.Count - rOff) _
.Find("*", , xlFormulas, , , xlPrevious)
If sCell Is Nothing Then Exit Sub
rCount = sCell.Row - rOff
Set srg = .Resize(rCount)
Set yrg = .Worksheet.Columns(yCols).Rows(.Row).Resize(rCount)
cCount = yrg.Columns.Count
End With
Dim sData As Variant: sData = srg.Value
ReDim Preserve sData(1 To rCount, 1 To 2)
Dim yData As Variant: yData = yrg.Value
Dim Result As Variant: ReDim Result(1 To cCount)
Dim c As Long, r As Long
For c = 1 To cCount
Result(c) = sData
For r = 1 To rCount
Result(c)(r, 2) = yData(r, c)
Next r
Next c
Erase yData
Erase sData
Dim dws As Worksheet
Dim drg As Range
Dim dName As String
Application.ScreenUpdating = False
For c = 1 To cCount
dName = Result(c)(1, 2)
On Error Resume Next
Set dws = Nothing
Set dws = wb.Worksheets(dName)
On Error GoTo 0
If Not dws Is Nothing Then
Application.DisplayAlerts = False
dws.Delete
Application.DisplayAlerts = True
End If
Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
dws.Name = dName
Set drg = dws.Range(dFirst).Resize(rCount, 2)
drg.Value = Result(c)
drg.Sort Key1:=drg.Cells(2), Order1:=xlDescending, Header:=xlYes
Next c
wb.Save
Application.ScreenUpdating = True
End Sub
I have about 50 Excel sheets in one folder, on my MacBook - (/Users/myusername/Desktop/Tidy/folder")
I want to perform the following Macro on them all:
Sub SmartCopy()
Dim s1 As Worksheet, s2 As Worksheet
Dim N As Long, i As Long, j As Long
Set s1 = Sheets("s1")
Set s2 = Sheets("s2")
N = s1.Cells(Rows.Count, "Y").End(xlUp).Row
j = 1
For i = 1 To N
If s1.Cells(i, "Y").Value = "No" Then
Else
s1.Cells(i, "Y").EntireRow.Copy s2.Cells(j, 1)
j = j + 1
End If
Next i
End Sub
I am struggling to get the sheets to open, almost like the filepath won't be recognised, also each sheet is named like this:
business-listing-002-w-site.csv
with one tab:
business-listing-002-w-site.csv
So I also need to either 1) rename the sheet each time 2) have the macro just open the only sheet in the workbook.
I want to copy all data from all workbooks into one master. I did try to add my Macro and adapt this one but just can't get it to run at all.
link to another post
You need to define the workbook (file), not just the sheet(tab).
Dim filePath as String
Dim sheetStart as String
Dim count as Integer
Dim sheetEnd as string
Dim thisSheet as Worksheet
Dim wb1 as Workbook
Dim ws1 as Worksheet
filePath = "/Users/myusername/Desktop/Tidy/folder/"
sheetStart = "business-listing-"
sheetEnd = "-w-site"
Set thisSheet as ThisWorkbook.Worksheets("Sheet1")
For count = 1 to 44 'the range of sheets you have
Set wb1 = Workbooks.Open(filePath & sheetStart & format(count, "000") & sheetEnd & ".csv")
Set ws1 = wb1.Worksheets(sheetStart & format(count, "000") & sheetEnd)
'move the ranges you want from ws1 to thisSheet
wb1.close
next count
each time the code loops, it will change the filename being opened and the sheet that it is looking for.
I assume you either know or can find how to copy a range from ws1 to the next available row of thisSheet based on the original code you provided.
edited with improved code based on comments
I have raw data from ANSYS mechanical exported as .xml with the following format (2 rows, x number of columns):
Steps Time [s] [A] C1 (Total) [N]
1 1 1, 4,4163e+005
I have a lot of files and I'm trying to combine these into one table in Excel using VBA. The script works fine with one exception, it does not interpret the scientific format correctly. My result is as follows:
Steps 1
Time [s] 1
[A] C1 (Total) [N] 4,42E+09
Code looks as follows:
Private Sub CommandButton1_Click()
Dim directory As String, fileName As String, sheet As Worksheet, total As Integer
Dim wb1 As Excel.Workbook
Dim wb2 As Excel.Workbook
Set wb1 = ThisWorkbook
wb1.Sheets("Sheet1").Cells.ClearContents
'define table headers on row 1
wb1.Sheets("Sheet1").Range("A1:A1").Value = "Load Case"
wb1.Sheets("Sheet1").Range("B1:B1").Value = "Load Case"
wb1.Sheets("Sheet1").Range("C1:C1").Value = "Load Case"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'directory of source files
directory = "C:\Users\xxxxxxx\Ansysxls\"
fileName = Dir(directory & "*.xl??")
'Define the last used row in the target sheet
LastRow = wb1.Sheets("Sheet1").Cells(wb1.Sheets("Sheet1").Rows.Count, "B").End(xlUp).Row + 1
Do While fileName = "Asymmetric.xls"
'define which workbook to open
Set wb2 = Workbooks.Open(directory & fileName)
'loop through sheets in source file
For Each sheet In Workbooks(fileName).Worksheets
'Select range in source file
wb2.Sheets(sheet.Name).Range("A1").CurrentRegion.Select
'Replace commas with dot
Selection.Replace What:=",", Replacement:=".", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Selection.Copy
'Paste Special to target file <-----Smth wrong in my paste special???
wb1.Sheets("Sheet1").Range("B" & LastRow).PasteSpecial _
Paste:=xlPasteValuesAndNumberFormats, SkipBlanks:=True, Transpose:=True
wb2.Sheets(sheet.Name).Activate
Next sheet
'define first row and last row of last import and add from what file the came
FirstRow = LastRow
LastRow = wb1.Sheets("Sheet1").Cells(wb1.Sheets("Sheet1").Rows.Count, "B").End(xlUp).Row + 1
'remove file ending ".xls" from column
wb1.Sheets("Sheet1").Range("A" & FirstRow & ":" & "A" & LastRow).Value = Left(fileName, Len(fileName) - 4)
Workbooks(fileName).Close
fileName = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
'Create Table
wb1.Sheets("Sheet1").ListObjects.Add(xlSrcRange, Sheets("Sheet1").Range("A1").CurrentRegion, , xlYes, Header = xlYes).Name = "myTable1"
End Sub
Can anybody help me understand why it changes with from e+5 to e+9?
Excel will 'interpret' the Total [N]) value (which has the comma in it) depending on the numbering system of your Excel application.
I believe if you paste a value of 4,4163e+005 into your worksheet, you will see a value of 4416300000, assuming your thousands are comma separated. In your case, however, you seem to want to convert the comma to a decimal point so that the true value is 441630. This can only be done if the value is a string, but yours probably isn't, it's most likely a number. I'm afraid I rather suspect your search and replace line makes no changes at all.
Although I can't see the values themselves, my bet would be that you need to divide each value by 10000 and then set the number format of your cells to "0.0000E+00".
I've put some code below that will loop through the values and make that change for you. You'll see that I've assumed each sheet only contains the 2 x 4 cell size, so adjust this if you need to.
Other comments about your code:
I think you need to put your last row update within the sheet loop. At a quick glance it looks as though you might be overwriting previous sheet data (ie the only data being written to your target is the source's last sheet data).
I'm not sure what you're intentions are with the Dir() function and then checking for a unique filename. It looks to me as if that will only loop once on a file called "Asymmetric.xls". If this is what you want then just define that workbook as an object. If you want to read all the workbooks in the directory then you need to run the Dir() loop until filename = "". That's what I've assumed in my code.
Private Sub CommandButton1_Click()
Dim directory As String
Dim fileName As String
Dim source As Workbook
Dim sht As Worksheet
Dim targetRng As Range
Dim rawValues As Variant
Dim revisedValues() As Variant
Dim rDimension As Long
Dim cDimension As Integer
Dim r As Long
Dim c As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'define table headers on row 1
With ThisWorkbook.Sheets("Sheet1")
.Cells.ClearContents
.Cells(1, 1).Resize(, 3).Value = _
Array("Filename", "Item", "Value")
Set targetRng = .Cells(2, 2) 'ie "B2"
End With
'Directory of source files
directory = "C:\Users\xxxxxxx\Ansysxls\"
fileName = Dir(directory & "*.xl??")
Do Until fileName = ""
'define which workbook to open
Set source = Workbooks.Open(directory & fileName)
'loop through sheets in source file
For Each sht In source.Worksheets
'Select range in source file
If Not IsEmpty(sht.Range("A1")) Then
rawValues = sht.Range("A1").CurrentRegion.Value2
' Manipulate the acquired data
rDimension = UBound(rawValues, 1)
cDimension = UBound(rawValues, 2)
' Transpose the dimensions and manipulate the totalN value
ReDim revisedValues(1 To cDimension, 1 To rDimension)
For r = 1 To rDimension
For c = 1 To cDimension
If r = 2 And c = 4 Then ' it's totalN
' Convert the data to a LongLong and divide by 10000
revisedValues(c, r) = CLngLng(rawValues(r, c)) / 10000
Else
revisedValues(c, r) = rawValues(r, c)
End If
Next
Next
'Populate the target sheet with revised values
Set targetRng = targetRng.Resize(cDimension, rDimension)
targetRng.Value2 = revisedValues
' Define the scientific format
targetRng.Cells(4, 2).NumberFormat = "0.0000E+00"
' Add the filename to column "A"
targetRng.Offset(, -1).Resize(, 1).Value2 = _
Left(fileName, (InStrRev(fileName, ".", -1, vbTextCompare) - 1))
' Move the targetRng to the bottom of this range
Set targetRng = targetRng.Offset(targetRng.Rows.Count)
End If
Next
source.Close
fileName = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I've been stuck on this for ages, it seems relatively simple in my head but I cant get it to work.. So what I need is say if I have a cell in workbook1 equals Bob, if that cell is in the same column in another workbook, copy that row..
So example.. if Bob in column A workbook1 is found in Column A workbook2 copy whatever is in the column b,c,d,e on bobs row into workbook2..
I could get it to work for singular ones easily but its for 500+ entries.
I've tried using arrays here is what I have got so far (the code is currently in a button on workbook1)
Dim owb As Workbook
Dim test1(500) As String, test2(500) As String, test3(500) As String, test4(500) As String
With Application
.DisplayAlerts = False
.ScreenUpdating = False
.EnableEvents = False
End With
fpath = "\Work\new location\test subject.xlsx" 'file location
Set owb = Application.Workbooks.Open(fpath) 'open file
For i = 1 To 500 'for each I
test1(i) = ThisWorkbook.Worksheets("Allsites").Cells(i, 1).Value
test2(i) = ThisWorkbook.Worksheets("Allsites").Cells(i, 8).Value
test3(i) = owb.Worksheets("Sheet2").Cells(i, 1).Value
test4(i) = owb.Worksheets("Sheet2").Cells(i, 2).Value 'declare locations
If test3(i) = test1(i) Then
test2(i) = test4(i)
End If
Next
In the example above, you're checking for a match in the exact cell (eg the value in A5 is the same as the one in A5), so I've assumed the same in the code below.
Dim sourceSheet As Worksheet
Dim destinationSheet As Worksheet
Dim columnNumber As Integer
Set sourceSheet = Worksheets("Sheet3")
Set destinationSheet = Worksheets("Sheet2")
Dim sourceArr() As Variant
Dim destArr() As Variant
sourceArr = sourceSheet.Range("A1:E500")
destArr = destinationSheet.Range("A1:E500")
For i = 1 To 500 'for each I
If destArr(i, 1) = sourceArr(i, 1) Then
For columnNumber = 2 To 5
destArr(i, columnNumber) = sourceArr(i, columnNumber)
Next
End If
Next
destinationSheet.Range("A1:A500").Value = destArr
There is a nice article about transferring data between arrays and worksheet ranges at http://www.cpearson.com/excel/ArraysAndRanges.aspx. Working with an array and writing the whole array in one go will be quicker than writing the value of each cell individually.
Update:
If the data can be in any row on the source spreadsheet, you can use Find to search for it. This may be quite a bit slower:
For i = 1 To 500 'for each I
Dim found As Range
Set found = searchRange.Find(destArr(i, 1), LookIn:=xlValues, lookat:=xlWhole)
If Not found Is Nothing Then
For columnNumber = 2 To 5
destArr(i, columnNumber) = found.Offset(0, columnNumber - 1)
Next
End If
Next
You may want to consider using a VLookup function in the worksheet rather than using VBA.
I'm currently having problems trying to extract cell data and pasting them into a new workbook. To make things clearer here are the steps
Access a specific worksheet ("Report") in all open workbooks (except the one running the macro)
From the worksheet, extract certain cell data (no. of rows and columns are not fixed but they are identical throughout the open workbooks)
Create a new workbook and paste the data there (each workbook will be assigned one row in the sheet, and all data extracted will be on the same sheet)
I'm having problems with my last sub that extracts this cell data and pastes it into a new workbook, here's what I have so far:
Function Extract_Report_Final(wb As Workbook, book As workbook, counter as long)
Dim last_row, last_col As Long
Dim ws As Worksheet
Dim i, j, k As Integer
Dim data() As String
With wb.Sheets("Report") 'for each worksheet in each open workbook
last_row = .Range("C" & .Rows.Count).End(xlUp).Row
last_col = .Cells(last_row, .Columns.Count).End(xlToLeft).Column
'to get the last row and column where the data required will be located
'this is identical throughout the workbooks as is the name of the worksheet
ReDim data(last_col - 1)
'I decided to use an array to store the values as i don't know how else :(
For k = 0 To (last_col - 2)
Select Case k
Case 0: data(k) = .Cells(1, 1).Value
Case 1: data(k) = .Cells(last_row, 3).Value
Case Else: data(k) = .Cells(last_row, k + 2).Value
End Select
Next k
k = 0
'A weak attempt at trying to copy.paste the values onto a new workbook
'I also don't know how to reference a newly created workbook :(
For i = 1 To last_col
'"book" is the variable workbook which will house the extracted data
.book.ws.Cells(counter, i) = data(k)
k = k + 1
Next i
End Function
Below is my main sub:
Sub Cycle_wb()
Dim ws As Worksheet
Dim wb As Workbook
Dim book As Workbook
Dim counter As Long, last_row As Long, last_col As Long
Dim i, j, k As Integer
Dim data() As String
counter = 1
open_close
Query_Tv_values
For Each wb In Workbooks
If wb.Name <> ThisWorkbook.Name Then
MsgBox "working on " & wb.Name
PerLineItem2 wb
Threshold_Value_PayFull wb
End If
Next
'It's just the part below which I'm having issues with :(
Set book = Workbooks.Add
Set ws = book.Sheets.Add(book.Sheets(1))
ws.Name = "Report_Final"
For Each wb In Workbooks
If (wb.Name <> ThisWorkbook.Name Or wb.Name <> book.Name) Then
Extract_Report_Final wb, counter, book
counter = counter + 1
Next wb
End Sub
Just use something like this to fill out the values in your new workbook
Cells(counter, i).Value = data(i-1)
Check the size of you array vs the length of your loops though - I think the "i"-loop should go
For i = 1 To last_col -1