So I have a list that was pre-assembled and I'm attempting to now add more to the list from another workbook I have. I figured I could use VBA to create a macro to perform a VLookup to retrieve and populate the added fields.
My VBA:
Option Explicit
Sub CompareUntimed()
Dim wb As Workbook
Dim utsheet As Worksheet
Dim utlastrow, f9lastrow, J As Long
Dim f9sheet As Worksheet
Dim ctr As Integer
Set wb = Workbooks.Open(get_user_specified_filepath())
Set utsheet = wb.Sheets(2)
utlastrow = utsheet.Cells(Rows.Count, "A").End(xlUp).Row
Set f9sheet = ThisWorkbook.Sheets("Part List")
f9lastrow = f9sheet.Cells(Rows.Count, "A").End(xlUp).Row
For J = 2 To f9lastrow
f9sheet.Range("G" & J) = Application.VLookup(f9sheet.Range("H" & f9lastrow), utsheet.Range("S2:S" & utlastrow), 17, False)
f9sheet.Range("F" & J) = Application.VLookup(f9sheet.Range("H" & f9lastrow), utsheet.Range("S2:S" & utlastow), 10, False)
Next J
End Sub
This is the Workbook where I'm getting #N/A instead of the proper values
This is the Workbook I'm attempting to match to and take values from
I'm attempting to use the UniqueID columns I've created which is the last column in each workbook and I'm attempting to add the dates and modified by columns to my new workbook.
Sub CompareUntimed()
Dim wb As Workbook
Dim utsheet As Worksheet
Dim utlastrow, f9lastrow, J As Long
Dim f9sheet As Worksheet
Dim ctr As Long
Set wb = Workbooks.Open(get_user_specified_filepath())
Set utsheet = wb.Sheets(2)
Set f9sheet = ThisWorkbook.Sheets("Part List")
f9lastrow = f9sheet.Cells(Rows.Count, "A").End(xlUp).Row
For J = 2 To f9lastrow
m = Application.Match(f9sheet.Range("H" & J), utsheet.Columns("S"), 0)
If Not IsError(m) Then
f9sheet.Range("G" & J).Value = utsheet.Cells(m, "K").Value
f9sheet.Range("F" & J).Value = utsheet.Cells(m, "R").Value
Else
f9sheet.Range("F" & J).Resize(1,2).Value = "???"
End If
Next J
End Sub
Related
I need to contactinate data of two columns from two different worksheets using vba macro.
Ex- in an excel sheet there are two tabs/worksheets sheet1 and sheet2. sheet1 is having column firstname & middlename, sheet2 is having column last name. I want to concat all first,middle & last name .
i am able to concat column which are present in same worksheet but not the column from different worksheets. Kindly suggest.
Thanks.
As you wanted a VBA solution, I've put something together for you. It checks if the number of rows in columns A in the two sheets are the same, loads the data from columns A/B in the first sheet and column A in the second sheet into an array, and then loops these arrays, concatenating then with spaces between using Trim to cater for missing values and writing this to the column B of the second sheet:
Sub sConcatenate()
Dim wsFName As Worksheet
Dim wsLName As Worksheet
Dim wsOutput As Worksheet
Dim lngLastRow As Long
Dim lngLoop1 As Long
Dim aFName() As Variant
Dim aMName() As Variant
Dim aLName() As Variant
Set wsFName = ThisWorkbook.Worksheets("FName")
Set wsLName = ThisWorkbook.Worksheets("LName")
Set wsOutput = ThisWorkbook.Worksheets("LName")
lngLastRow = wsFName.Cells(wsFName.Rows.Count, "A").End(xlUp).Row
If lngLastRow = wsOutput.Cells(wsOutput.Rows.Count, "A").End(xlUp).Row Then
aFName = wsFName.Range("A1:A" & lngLastRow).Value
aMName = wsFName.Range("B1:B" & lngLastRow).Value
aLName = wsLName.Range("A1:A" & lngLastRow).Value
For lngLoop1 = LBound(aFName, 1) To UBound(aFName, 1)
wsOutput.Cells(lngLoop1, 2) = Trim(Trim(aFName(lngLoop1, 1) & " " & aMName(lngLoop1, 1)) & " " & aLName(lngLoop1, 1))
Next lngLoop1
End If
Set wsFName = Nothing
Set wsLName = Nothing
Set wsOutput = Nothing
End Sub
Regards,
Why don't you just use the CONCATENATE function? Open both workbooks and in the destination cell write the CONCATENATE function with the directions.
=CONCATENATE(Cell from Workbook 1," ",Cell from Workbook 2)
You didn't mention the details of your use case. But if you want something programatic, the code below shows how you can reference different workbooks and worksheets. You can a for loop and modify it for your use case.
Sub conc()
Dim destination_Wb as Workbook, wb1 As Workbook, wb2 As Workbook
Dim destination_Ws as Worksheet, ws1 As Worksheet, ws2 As Worksheet
Set destination_Wb = Workbooks(“Destination Workbook.xlsm”)
...
...
Set destination_Ws = destination_Wb.Sheets("Sheet1")
...
...
destination_Ws.Cells(1, 1).Value = ws1.Cells(1, 1).Value + " " + ws2.Cells(1, 1).Value
End sub
Concatenate Columns
Adjust the values in the constants section.
The Code
Option Explicit
Sub ConcatNames()
Const Source As String = "Sheet1"
Const Target As String = "Sheet2"
Const NameColumn As Long = 1
Const MiddleNameColumn As Long = 2
Const LastNameColumn As Long = 1
Const FullNameColumn As Long = 2
Const FirstRow As Long = 2
Dim rng As Range
Dim vName, vMiddle, vLast, vFull
Dim RowsCount As Long, i As Long
Dim CurrString As String
With ThisWorkbook.Worksheets(Source)
Set rng = .Columns(NameColumn).Find(What:="*", _
LookIn:=xlFormulas, SearchDirection:=xlPrevious)
Set rng = .Range(.Cells(FirstRow, NameColumn), rng)
vName = rng
RowsCount = rng.Rows.Count
Set rng = .Cells(FirstRow, MiddleNameColumn).Resize(RowsCount)
vMiddle = rng
End With
With ThisWorkbook.Worksheets(Target)
Set rng = .Cells(FirstRow, LastNameColumn).Resize(RowsCount)
vLast = rng
End With
ReDim vFull(1 To RowsCount, 1 To 1)
For i = 1 To RowsCount
GoSub BuildString
Next i
With ThisWorkbook.Worksheets(Target)
Set rng = .Cells(FirstRow, FullNameColumn).Resize(RowsCount)
rng = vFull
End With
Exit Sub
BuildString:
If vName(i, 1) = "" Then Return
CurrString = vName(i, 1)
If vMiddle(i, 1) <> "" Then CurrString = CurrString & " " & vMiddle(i, 1)
If vLast(i, 1) <> "" Then CurrString = CurrString & " " & vLast(i, 1)
vFull(i, 1) = WorksheetFunction.Trim(CurrString)
Return
End Sub
Previously, when I created the worksheets index 1,2,3 in excel,
it can be sorted into like this in index 1 2 and 3 respectively
But now if i stop creating worksheets in excel but through VBA instead, the data cant be populated and it leaves index 1,2 and 3 empty.
This is the code that I used for populating the data but with the addition of add.sheets. The add.sheets here are for creating index1,2,3 worksheets but they doesn't trigger the program to continue to populate the data even though these worksheets exists when I program them in VBA.
Sub UpdateVal()
Static count As Long
Dim iRow As Long
Dim aRow As Long
Dim a As Long
Dim b As Long
Dim selectRange As Range
Dim lastline As Integer
Dim sheetname As String
Dim indexrowcount As Integer
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
Set ws = wb.Worksheets("Result")
Set site_ai = Sheets.Add(after:=Sheets(Worksheets.count))
site_ai.Name = "Index1"
Set site_bi = Sheets.Add(after:=Sheets(Worksheets.count))
site_bi.Name = "Index2"
Set site_ci = Sheets.Add(after:=Sheets(Worksheets.count))
site_ci.Name = "Index3"**
'^additional codes sheets.Add added here for creating worksheets namely index1,2,3
j = 2
iRow = 1
lastline = ws.UsedRange.Rows.count
While iRow < lastline + 1
a = iRow + 1
b = iRow + 17 ' Max Group Size with Same name in F to H column
count = 1
If ws.Cells(iRow, "F").Value = "Martin1" Then
sheetname = "Index1"
ElseIf ws.Cells(iRow, "F").Value = "John1" Then
sheetname = "Index2"
Else
sheetname = "Index3"
End If
For aRow = a To b
If ws.Cells(iRow, "F") = ws.Cells(aRow, "F") And ws.Cells(iRow, "G") = ws.Cells(aRow, "G") And ws.Cells(iRow, "H") = ws.Cells(aRow, "H") Then
count = count + 1
Else
Set selectRange = Range("A" & iRow & ":J" & aRow - 1)
selectRange.Copy
indexrowcount = Sheets(sheetname).UsedRange.Rows.count
Sheets(sheetname).Range("A" & indexrowcount).PasteSpecial xlPasteAll
iRow = iRow + count
Exit For
End If
Next aRow
Wend
End Sub
what am I missing here and how should i solve it?
Your code is too confusing. If your example data is accurate, I don't understand why you need to check all three columns. You can accomplish what you are trying to do, by just using column F. If your data is already sorted as shown, then I would loop through column F testing for duplicates until no match. I would then add a worksheet and name it using the start cells' value. Then copy the rows from the start cell to the current rwNbr - 1 and paste to the new worksheet. Reset the start cell for the next group and loop.
Sub SaveRangewithConsecutiveDuplicateValuestoNewSheet()
'Define all variables
Dim wb As Workbook, ws As Worksheet, sCel As Range, rwNbr As Long
Set wb = ThisWorkbook 'Set workbook variable
Set ws = wb.Worksheets("Sheet1") 'set worksheet variable using workbook variable
Set sCel = ws.Cells(1, 6) 'Set the first start cell variable to test for duplicate values
Application.DisplayAlerts = False
For rwNbr = 2 To ws.Cells(ws.Rows.count, 6).End(xlUp).Offset(1).Row Step 1 'Loop
If ws.Cells(rwNbr, 6).Value <> sCel.Value Then 'loop until the value changes
wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.count)).Name = sCel.Value 'Add sheet and name based on the first cell of group
ws.Range(sCel, ws.Cells(rwNbr - 1, 6)).EntireRow.Copy Destination:=ActiveSheet.Range("A1") 'select group of consecutive duplicates
Set sCel = ws.Cells(rwNbr, 6) 'reset start cell to test for the next group of consecutive duplicates
End If
Next rwNbr
Application.DisplayAlerts = True
End Sub
My code is working when I just use a single workbook and communicate between sheets but gives me subscript out of range errors and object not defined errors when I attempt to reference a cell range in a sheet contained in a different work book. Right now, the error is occurring at "Set pidat = Worksheets("pidat")
Dim pival As Double
'Dim eom As Worksheet 'declaring pidat worksheet as variable
'Set eom = Worksheets("EOM") 'declaring eom worksheet as variable
'Set Inv_Level = Worksheets("Inv_Levels")
Dim pidat As Worksheet 'declaring eom worksheet as variable
Set pidat = Worksheets("pidat")
Dim steve As Workbook
Set steve = Application.Workbooks("EOM Report VBA")
Dim EOMAs As Workbook
Set EOMAs = Application.Workbooks("EOMA")
Dim Inv_Level As Worksheet
'These changes allow for a dynamic range to be referenced outside of the active sheet/workbook
Dim location As String
Dim rownum As Long
Dim loopy As Long
Dim fRng As Range
Dim J As Long
Dim rn As Date
Dim last As Date
Dim rnm As Integer
Dim lastm As Integer
Dim tyear As Long
Dim K As Long
With pidat
J = .Range("J2").Value
rn = Now
last = .Range("B1").Value
rnm = month(rn)
lastm = month(last)
tyear = year(rn)
If lastm < rnm Then
.Range("B1") = (rnm & "/" & "01" & "/" & tyear & " 07:30")
J = J + 100
.Range("J2") = J
End If
End With
K = J + 100
'names of workbook/sheet referenced
With steve
rownum = .Range("E" & Rows.Count).End(xlUp).Row 'counts the number of rows in the location tag column
For loopy = 3 To rownum 'Data values start after row 3, loops through each row in the column
If .Range("E" & loopy) <> "" Then
location = .Range("E" & loopy)
'newloc = location
With Inv_Level
Set fRng = .Cells.Range("A" & J, "ZZ" & K).Find(What:=location, LookIn:=xlFormulas, LookAt:=xlPart) 'eom can be any sheet you need to perform the .Find again
End With
If Not fRng Is Nothing Then
fRng.Offset(0, -1) = pidat.Range("D" & loopy)
Else: End If
'if the search item is not found, do nothing, go to next loop
End If
Next loopy
End With
End Sub
You need to qualify the specific workbook you want to work with.
The line Set pidat = Worksheets("pidat") will fail if the active workbook at the time this line is executed has no worksheet named pidat.
Here is an example of how to qualify a workbook
Dim theWorkbook as Workbook
Set theWorkbook = Application.Workbooks("myWorkbook")
Dim pidat as Worksheet
Set pidat = theWorkbook.Worksheets("pidat")
You could go one step further and verify that a sheet named pidat (or whatever) exists in the qualified workbook, but I'll leave you to discover how to do that :)
I have 2 columns on a sheet "list", one column that lists all business entities, the other lists all org units. The functionality of the code below works perfectly but returns an error because it exceeds the sheet row limit.
The data is pasted onto a sheet "cc_act" is there a way to at point of error create a new sheet called "cc_act1"...."cc_act2" until the script is complete?
Declare Function HypMenuVRefresh Lib "HsAddin" () As Long
Sub cc()
Application.ScreenUpdating = False
Dim list As Worksheet: Set list = ThisWorkbook.Worksheets("list")
Dim p As Worksheet: Set p = ThisWorkbook.Worksheets("p")
Dim calc As Worksheet: Set calc = ThisWorkbook.Worksheets("calc")
Dim cc As Worksheet: Set cc = ThisWorkbook.Worksheets("cc_act")
Dim cc_lr As Long
Dim calc_lr As Long: calc_lr = calc.Cells(Rows.Count, "A").End(xlUp).Row
Dim calc_lc As Long: calc_lc = calc.Cells(1,
calc.Columns.Count).End(xlToLeft).Column
Dim calc_rg As Range
Dim ctry_rg As Range
Dim i As Integer
Dim x As Integer
list.Activate
For x = 2 To Range("B" & Rows.Count).End(xlUp).Row
If list.Range("B" & x).Value <> "" Then
p.Cells(17, 3) = list.Range("B" & x).Value
End If
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
If list.Range("A" & i).Value <> "" Then
p.Cells(17, 4) = list.Range("A" & i).Value
p.Calculate
End If
p.Activate
Call HypMenuVRefresh
p.Calculate
'''changes country on calc table
calc.Cells(2, 2) = p.Cells(17, 4)
calc.Cells(2, 3) = p.Cells(17, 3)
calc.Calculate
'''copy the calc range and past under last column
With calc
Set calc_rg = calc.Range("A2:F2" & calc_lr)
End With
With cc
cc_lr = cc.Cells(Rows.Count, "A").End(xlUp).Row + 1
calc_rg.Copy
cc.Cells(cc_lr, "A").PasteSpecial xlPasteValues
End With
Next i
Next x
Application.ScreenUpdating = True
End Sub
I suppose there are a few ways to handle something like this. See the code sample below, and adapt it to your specific needs.
Sub LongColumnToAFewColumns()
Dim wsF As Worksheet, WST As Worksheet
Dim rf As Range, rT As Range
Dim R As Long, j As Integer
' initialize
Set wsF = ActiveSheet
Set WST = Sheets.Add
WST.Name = "Results"
j = 1
For R = 1 To wsF.Cells(Rows.Count, 1).End(xlUp).Row Step 65536
wsF.Cells(R, 1).Resize(65536).Copy
WST.Cells(j, 1).PasteSpecial xlPasteValues
WST.Cells(j, 1).PasteSpecial xlPasteValues
j = j + 1
Next R
End Sub
As an aside, you may want to consider using MS Access for this kind of thing. Or, better yet, Python or even R. Good luck with your project.
I would like to export data from a consolidated sheet (DATA) to multiple sheets regarding criteria.
I have a total of 13 criteria, each criteria has to be exported in its dedicated sheet.
I'm trying to optimize this macro (only 2 criteria here) because it lag out
Sub copy()
Application.ScreenUpdating = False
Dim i As Long
Dim j As Long
Dim sh As Worksheet
Dim feuillePrincipale As Worksheet
Dim S01Sheet As Worksheet
Dim S02Sheet As Worksheet
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
Set S01Sheet = ThisWorkbook.Sheets("S01")
Set S02Sheet = ThisWorkbook.Sheets("S02")
For Each sh In ThisWorkbook.Worksheets
If sh.Name = "S01" Then
i = 2
j = 2
While Not IsEmpty(feuillePrincipale.Cells(i, 1))
If feuillePrincipale.Cells(i, 11).Value Like "S01*" Then
feuillePrincipale.Cells.Rows(i).EntireRow.copy S01Sheet.Rows(j)
j = j + 1
End If
i = i + 1
Wend
End If
If sh.Name = "S02" Then
i = 2
j = 2
While Not IsEmpty(feuillePrincipale.Cells(i, 1))
If feuillePrincipale.Cells(i, 11).Value Like "S02*" Then
feuillePrincipale.Cells.Rows(i).EntireRow.copy S02Sheet.Rows(j)
j = j + 1
End If
i = i + 1
Wend
End If
Next
Application.ScreenUpdating = True
End Sub
If you have any idea, I read I can use Advanced filter but as you guess I'm new in VBA so I'm listening any tips!
Here is the Advanced Filter method you asked for:
Public Sub Christophe()
Const FILTER_COLUMN = 11
Dim i&, rCrit As Range, rData As Range, aShts
aShts = ["SO"&row(1:13)]
Set rData = Sheets("DATA").[a1].CurrentRegion
Set rCrit = rData.Resize(2, 1).Offset(, rData.Columns.Count + 2)
rCrit(1) = rData(1, FILTER_COLUMN)
For i = 1 To UBound(aShts)
rCrit(2) = aShts(i, 1) & "*"
rData.AdvancedFilter xlFilterCopy, rCrit, Sheets(aShts(i, 1)).[a1].Resize(, rData.Columns.Count)
Next
rCrit.Clear
End Sub
The execution time should be instantaneous.
Note: this assumes that you do have 13 criteria, each starting with "SO" and that they occupy column 11 of the Data sheet. It also assumes that you already have 13 sheets named SO1... SO13 in the workbook.
UPDATE
Based on new information that the pattern of the criteria can change, please try this version instead. Note, that it assumes that the sheets already exist and that the sheet names match the criteria:
Public Sub Christophe()
Const FILTER_COLUMN = 11
Dim i&, rCrit As Range, rData As Range, aShts
aShts = Array("SO1", "SO2", "ADQ03", "LocS10")
Set rData = Sheets("DATA").[a1].CurrentRegion
Set rCrit = rData.Resize(2, 1).Offset(, rData.Columns.Count + 2)
rCrit(1) = rData(1, FILTER_COLUMN)
For i = 0 To UBound(aShts)
rCrit(2) = aShts(i) & "*"
rData.AdvancedFilter xlFilterCopy, rCrit, Sheets(aShts(i)).[a1].Resize(, rData.Columns.Count)
Next
rCrit.Clear
End Sub
Try using an array to set your criteria sheets:
Dim shArray As Variant
Dim shArrayString As String
Dim feuillePrincipale As Excel.Worksheet
Dim i As Long
Dim j As Long
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
j = 1
'// Create array and populate
shArray = Array("S01", "S02", "S03", "S04") '// add as required
'// Create string representation of array
shArrayString = "{"""
For i = LBound(shArray) To UBound(shArray)
shArrayString = shArrayString & shArray(i) & ""","""
Next
shArrayString = Left(shArrayString, Len(shArrayString) - 2) & "}"
'//Start loop
With feuillePrincipale
For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
If Not Evaluate("ISERROR(MATCH(" & Left(.Cells(i, 11), 3) & "," & shArrayString & ",0))") Then
.Rows(i).Copy Sheets(shArray(WorksheetFunction.Match(Left(.Cells(i, 11), 3), shArray, 0))).Cells(j, 1)
j = j + 1
End If
Next
End With
It's a bit unclear because if you follow the code you've posted - it's actually just copying and pasting data to the same sheet...
Yes, you should use an autofilter and use a special select to get only the visible cells.
If you want the loop method, you should loop through each row on sheets("DATA") and use a Select Case Statement to decide onto which sheet the data is placed.
By looping through each sheet you are adding loops that will slow it down.
Application.ScreenUpdating = False
Dim i As Long
Dim j As Long
Dim cel As Range
Dim sh As Worksheet
Dim feuillePrincipale As Worksheet
Dim S01Sheet As Worksheet
Dim S02Sheet As Worksheet
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
Set S01Sheet = ThisWorkbook.Sheets("S01")
Set S02Sheet = ThisWorkbook.Sheets("S02")
For Each cel In feuillePrincipale.Range(feuillePrincipale.Range("A1"), feuillePrincipale.Range("A1").End(xlDown))
Select Case Left(cel.offset(,10).value, 3)
Case "S01"
j = S01Sheet.Range("A" & Rows.count).End(xlUp).Offset(1).Row
feuillePrincipale.Cells.Rows(cel.Row).EntireRow.copy S01Sheet.Rows(j)
Case "S02"
j = S02Sheet.Range("A" & Rows.count).End(xlUp).Offset(1).Row
feuillePrincipale.Cells.Rows(cel.Row).EntireRow.copy S02Sheet.Rows(j)
'Case .... keep adding select statement till you get to the last condition
Case Else
End Select
Next cel
Application.ScreenUpdating = True