So I have a workbook with two sheets in it. I need to copy data from worksheet 2 ("Detail") to worksheet 1 ("Syncrofit"). The items from ws2 I need to paste into progressive rows on sheet 1, so rows in sheet two, column B which say "Joint1-1" need to be inserted below row 1 on sheet 1. This essentially creates a nested table.
Here's what I have so far, mostly scraped together from code and help I've found around here:
Sub SelectJoints()
Sheets("Detail").Activate
Dim Selection1 As Integer, Selection2 As Integer
Dim SelectionRange As Range
Dim num As Integer
Dim rngFind As Range
Set rngFind = Columns("B:B").Find(what:="*" & "Joint1-" & num, After:=Range("B1"), LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not rngFind Is Nothing Then
Selection1 = rngFind.Row + 1
End If
Set rngFind = Columns("B:B").Find(what:="*Joint1-" & num + 1, After:=Range("B1"), LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not rngFind Is Nothing Then
Selection2 = rngFind.Row - 1
End If
If Selection1 > 0 And Selection2 > 0 Then
Set SelectionRange = Range(Cells(Selection1, 2), Cells(Selection2, 6))
End If
End Sub
The intent here is that this should activate the detail sheet, find strings in column B which match SomeTextHere(Joint1-1) and select those rows. I then need it to paste those selections over to sheet 1 (below row 1, which has a value matching the Joint value in one of the columns), come back to sheet 2, select the rows containing SomeTextHere(Joint1-2) and paste those below the next row (after those which were just inserted). I realize that the pasting part of that is not in the code. This has been driving me nuts.
Please excuse my lack of knowledge in regards to VBA.
I'd like the finished product to look like a nested table kind of like follows:
Original Items
Copied from sheet 2
Copied from sheet 2
Copied from sheet 2
Original Item 2
Copied from sheet 2
etc.
I was a bit bored so I whipped up something that might help you. Let me know if it works for you.
Sub Macro1()
Dim i, j, x
Dim rng As Range
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Set sh1 = Sheets("Syncrofit")
Set sh2 = Sheets("Detail")
lr = sh2.Range("B" & Rows.Count).End(xlUp).Row
lc = sh2.Cells(2, Columns.Count).End(xlToLeft).Column
j = 2
For y = 1 To 3 ' set upper limit of first integer in Joint string
For x = 1 To 2 ' set upper limit of second integer in Joint string
For i = 2 To lr
If InStr(sh2.Cells(i, 2), "Joint" & y & "-" & x) <> 0 Then
sh2.Range(sh2.Cells(i, 1), sh2.Cells(i, lc)).Copy
sh1.Rows(j).Insert
j = j + 1
End If
Next i
Next x
Next y
End Sub
Related
I am trying to make a VBA code which matches at least 2 criteria.
I would like to return rows where in column C there is "ACMA" and in column T is "0".
It should be listed as below in other sheet:
I tried every formulas on the internet and other users' codes but it does not work. Can you please provide me on a proper way?
Like #CLR mentioned you'll need to check if column T is returning 0 because it's blank or because it's actually 0. For this solution I checked the length of the value in the cell <> 0 (i.e. blank).
Sub ReturnMatches()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lastRow1 As Long, newRow2 As Long
Dim x As Long
'don't know the names of your sheets so adjust accordingly
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
'determine last row of data sheet
lastRow1 = ws1.Cells(ws1.Rows.Count, 3).End(xlUp).Row
For x = 2 To lastRow1
'check to see if it is a match
'for T, also check length of value in cell <> 0 (i.e. blank)
If _
ws1.Cells(x, 3) = "ACMA" And _
ws1.Cells(x, 20) = 0 And Len(ws1.Cells(x, 20).Value) <> 0 Then
'define first blank row of 2nd sheet
newRow2 = ws2.Cells(ws1.Rows.Count, 1).End(xlUp).Row + 1
'copy matching information to first blank row
ws2.Cells(newRow2, 1) = "ACMA"
ws2.Cells(newRow2, 2) = ws1.Cells(x, 4)
End If
Next x
End Sub
I'm currently reorganizing some columns using VBA code and I need to make a change to one of the header rows and the values in 1 specific column. I've included what I'm basically trying to do in a comment. Here is the code I'm using but very cut down for brevity.
Sub columnOrder2()
Dim search As Range
Dim cnt As Integer
Dim colOrdr As Variant
Dim indx As Integer
colOrdr = Array("User name", "LanID", "Asset Tag")
cnt = 1
For indx = LBound(colOrdr) To UBound(colOrdr)
Set search = Rows("1:1").Find(colOrdr(indx), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
' If search = "LanID" then change header row to "Last3"
' and return only the last 3 characters for values in cells
If Not search Is Nothing Then
If search.Column <> cnt Then
search.EntireColumn.Cut
Columns(cnt).Insert Shift:=xlToRight
Application.CutCopyMode = False
End If
cnt = cnt + 1
End If
Next indx
End Sub
Currently, I'm just running the code and manually renaming the column then creating a formula in cell g2 and using =Right(G2,3) and copying it down to the rest of the cells in column C. I know VBA can do this much better and maybe even just in a separate function. Any help would be appreciated. I haven't worked with Excel VBA for awhile now.
Assuming you mean to overwrite the LANId column with its own last three characters, you could code as follows (C2 instead of G2 in your question?):
Modified code close to OP
Includes a fully qualified (worksheet) range reference, btw (as otherwise VBA assumes any currently active worksheet) :-)
Sub columnOrder2()
Dim ws As Worksheet: Set ws = Sheet1 ' << Using e.g. the sheet's Code(Name)
Dim colOrdr As Variant
colOrdr = Array("User name", "LanID", "Asset Tag")
Dim cnt As Long
cnt = 1
Dim indx As Long
For indx = LBound(colOrdr) To UBound(colOrdr)
Dim search As Range
Set search = ws.Rows("1:1").Find(colOrdr(indx), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
If Not search Is Nothing Then
If LCase(search.Text) = "lanid" Then
'set column range object to memory
Dim rng As Range
Set rng = getColRange(ws, search.Column, Startrow:=1)
'return only the last 3 characters
rng.Value = Evaluate("=Right(" & rng.Address & ",3)")
'change header cell from "LANId" to "Last3"
rng(1, 1) = "Last3" ' change header from LANId to Last3
End If
If search.Column <> cnt Then
search.EntireColumn.Cut
Columns(cnt).Insert Shift:=xlToRight
Application.CutCopyMode = False
End If
cnt = cnt + 1
End If
Next indx
End Sub
Help function
Returns the range of a given sheet column up to the last row with a value:
Function getColRange(mySheet As Worksheet, _
Optional ByVal myColumn As Variant = "A", _
Optional ByVal Startrow As Long = 1) As Range
With mySheet
'a) change numeric column number to letter(s)
If IsNumeric(myColumn) Then myColumn = Split((.Columns(myColumn).Address(, 0)), ":")(0)
'b) get last row in given column
Dim lastRow As Long
lastRow = .Range(myColumn & .Rows.Count).End(xlUp).Row
'c) return data range as function result
' (a Range is an Object and has to be SET!)
Set getColRange = .Range(myColumn & Startrow & ":" & myColumn & lastRow)
End With
End Function
Related link
Instead of moving entire columns one after the other you might be interested in an array approach - c.f. Delete an array column and change position of two columns
Hoping you can help, please!
So I have 2 worksheets, 1 & 2. Sheet1 has already existing data, Sheet2 is used to dump raw data into. This is updated daily, and the data dump includes both data from previous days, as well as new data. The new data may include rows relating to interactions that may have happened earlier in the month, not just the previous day. So the data is not "date sequential".
There are 9 columns of data, with a unique identifier in column I.
What I'm needing to happen is when running the macro, it looks in column I in Sheet1 and Sheet2, and only copies and pastes rows where the unique identifier in Sheet 2 doesn't already exist in Sheet1. And pastes them from the last empty row onwards in Sheet1.
What I currently have is this - it's all I could find online:
Sub CopyData()
Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim rng As Range
Dim foundVal As Range
For Each rng In Sheets("Sheet2").Range("A1:I" & LastRow)
Set foundVal = Sheets("Sheet1").Range("I:I").Find(rng, LookIn:=xlValues, LookAt:=xlWhole)
If foundVal Is Nothing Then
rng.EntireRow.Copy Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
Next rng
Application.ScreenUpdating = True
End Sub
But it's just not working - not only does it not recognise if the value in column I already exists, it's copying and pasting only the first 2 rows from Sheet2, but duplicating them 8 times each!
Apologies in advance, I'm a real VBA novice, and just can't work out where it's all going wrong. I would appreciate any assistance!
This will do what you want:
Sub testy()
Dim wks As Worksheet, base As Worksheet
Dim n As Long, i As Long, m As Long
Dim rng As Range
Set wks = ThisWorkbook.Worksheets(2) 'Change "2" with your input sheet name
Set base = ThisWorkbook.Worksheets(1) 'Change "1" with your output sheet name
n = base.Cells(base.Rows.Count, "A").End(xlUp).Row
m = wks.Cells(wks.Rows.Count, "A").End(xlUp).Row
For i = 2 To m
On Error Resume Next
If IsError(WorksheetFunction.Match(wks.Cells(i, 9), base.Range("I:I"), 0)) Then
Set rng = wks.Cells(i, 1).Resize(1, 9) 'Change 9 with your input range column count
n = n + 1
base.Cells(n, 1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
End If
Next i
End Sub
I have an Excel worksheet ("All Documents") that is populated from a SharePoint list but also has some columns that contain formulas. I have another worksheet in the same workbook ("Original") that contains the original values of the list items. I need to compare the two worksheets and if the value in column A in "All Documents" does not exist in column A in "Original" it needs to copy the row to the "Original" sheet. It must be pasted as values. I have searched many forums and tried many suggestions but none worked. This is my latest attempt. Any assistance will be appreciated!
Dim x As Long, y As Long, a As Long
Dim b As String
Dim rFound As Range
Dim TargetRange As Range
x = Worksheets("All Documents").Range("A" & Rows.Count).End(xlUp).Row
For a = 2 To x
y = Worksheets("Original").Range("A" & Rows.Count).End(xlUp).Row
b = Worksheets("All Documents").Range("A" & a)
If a > y Then Exit For
With Worksheets("Original").Range("A:A")
Set rFound = .Find(b, LookIn:=xlValues)
If rFound Is Nothing Then
TargetRange = Worksheets("Original"1).Cells(Worksheets("Original").Rows(y + 1))
Worksheets("All Documents").Rows(a).Copy
TargetRange.PasteSpecial xlPasteValues
End If
End With
Next a
Three things,
To set a range you need to:
Set TargetRange = Worksheets("Original").Rows(y + 1)
Check to see if the sheet is ment to be "Original"1 or "Original"
And an improvement copy your values by:
Worksheets("Original").Rows(y + 1).Value = _
Worksheets("All Documents").Rows(a).Value
I am currently using the Macro below for excel to move data from one one sheet to another. It is set up to fill from Row 2 down, as long as the rows are empty. I not want to have it already contain data in Columns 2 & 3. I have tried a number of things and am not having a lot of luck. I am new to this and "fixing" someone else's macro.
Sub MergeSheets()
Sheets("New").Activate
LastRowNew = Application.WorksheetFunction.CountA(Columns(1))
For i = 2 To LastRowNew
OrderNumber = Cells(i, 3)
Sheets("PRIOrders").Activate
LastRowPRI = Application.WorksheetFunction.CountA(Columns(1))
For j = 2 To LastRowPRI
If Cells(j, 3) = OrderNumber Then
Exit For
ElseIf j = LastRowPRI Then
Sheets("New").Rows(i).Copy Destination:=Sheets("PRIOrders").Rows(LastRowPRI + 1)
Sheets("PRIOrders").Rows(2).Copy
Sheets("PRIOrders").PasteSpecial xlPasteFormats
End If
Next
Sheets("New").Activate
Next
Sub MergeSheets()
Dim shtNew As Worksheet, shtOrders As Worksheet
Dim rngOrder As Range, rngNewOrders As Range
Dim f As Range, lastRow As Long
Set shtNew = ActiveWorkbook.Sheets("New")
Set rngNewOrders = shtNew.Range(shtNew.Range("C2"), _
shtNew.Cells(Rows.Count, 3).End(xlUp))
Set shtOrders = ActiveWorkbook.Sheets("PRIOrders")
For Each rngOrder In rngNewOrders.Cells
Set f = shtOrders.Columns(3).Find(Trim(rngOrder.Value), , xlValues, xlWhole)
If f Is Nothing Then
'find the last occupied row in Col B or C
lastRow = Application.Max(shtOrders.Cells(Rows.Count, 2).End(xlUp).Row, _
shtOrders.Cells(Rows.Count, 3).End(xlUp).Row)
rngOrder.EntireRow.Copy shtOrders.Cells(lastRow + 1, 1)
End If
Next rngOrder
End Sub