I have two sheets, Sheet1 & Sheet2, with same header names.
Header names are not in same order.
Sheet2 has more headers than Sheet1.
Headers of Sheet1 are located on C4:AG4.
Headers of Sheet2 are located on F6:EK6.
I would like to match header names between sheets, and copy data & formulas of each column from Sheet1 to appropriate columns of Sheet2.
Sub Oval4_Click()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1") 'Sheet that has data
Dim LRow As Long, Found As Range
Set Found = ws.Range("C4:AG4").Find("*Invoice Number") 'Header name to search for
If Not Found Is Nothing Then
LRow = ws.Cells(ws.Rows.Count, Found.Column).End(xlUp).Row
ws.Range(ws.Cells(7, Found.Column), ws.Cells(LRow, Found.Column)).Copy
'Sheet to paste data
ActiveWorkbook.Sheets("Sheets2").Range("H7").PasteSpecial xlPasteFormulas
End If
End Sub
I am able to copy data to Sheet2 one by one.
As I have around 30 column headers on Sheet1, is there a way to add a loop to copy all data?
This is really just a case of using Application.WorksheetFunction.Match() to get the destination column to paste the data to. Something like the following would do it:
Option Explicit
Dim SourceHeader As Range, DestHeader As Long, LastRow As Long, myCol As Long, myRow As Long
Sub CopyUsingHeaders()
For Each SourceHeader In Sheet1.Range("C4:AG4")
myCol = SourceHeader.Column
myRow = SourceHeader.Row
With Sheet1
LastRow = .Cells(.Rows.Count, myCol).End(xlUp).Row
End With
With Sheet2
DestHeader = Application.WorksheetFunction.Match(SourceHeader, Sheet2.Range("A6:EK6"), 0)
End With
Sheet1.Range(Sheet1.Cells(myRow, myCol), Sheet1.Cells(LastRow, myCol)).Copy _
Sheet2.Cells(7, DestHeader)
Next
End Sub
Related
I have been running into some issues trying to use VBA to compare 2 tables in different worksheets, and then copy any rows in the "Master" sheet that are not found in the "New" sheet. Both tables are formatted as tables. The match is based on an "ID" column in Column A of both tables. If an ID is in the "Master" sheet, but not in the "New" sheet, than that entire row should be copy and pasted to the end of the table in the "New" sheet.
I updated some code found in another forum, which is almost working. However, it only seems to paste over the ID data into Column A, and not the entire corresponding row of data which is needed.
Sub compare()
Dim i As Long
Dim lrs As Long
Dim lrd As Long
With Worksheets("Master")
lrs = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 2 To lrs 'assumes header in row 1
If Application.IfError(Application.Match(.Cells(i, 1), Worksheets("New").Columns(1), 0), 0) = 0 Then
lrd = Worksheets("New").Cells(Worksheets("test").Rows.Count, 1).End(xlUp).Row
Worksheets("New").Cells(lrd + 1, 1).Value = .Cells(i, 1).Value
End If
Next i
End With
End Sub
I think the issue has to do with the "Cells" reference, instead of a range, but I do not know how to make that line dynamic.
Slightly different approach, but you need to use something like Resize() to capture the whole row, and not just the cell in Col A.
Sub compare()
Const NUM_COLS As Long = 10 'for example
Dim wb As Workbook, wsSrc As Worksheet, wsDest As Worksheet
Dim c As Range, cDest As Range
Set wb = ThisWorkbook 'or ActiveWorkbook for example
Set wsSrc = wb.Worksheets("Master")
Set wsDest = wb.Worksheets("New")
Set cDest = wsDest.Cells(Rows.Count, 1).End(xlUp).Offset(1) 'next empty row
For Each c In wsSrc.Range("A2:A" & wsSrc.Cells(Rows.Count, 1).End(xlUp).Row).Cells
If IsError(Application.Match(c.Value, wsDest.Columns(1), 0)) Then
cDest.Resize(1, NUM_COLS).Value = c.Resize(1, NUM_COLS).Value
Set cDest = cDest.Offset(1) 'next row
End If
Next c
End Sub
i am stuck with my procject again... I tried with formulas but i can t make it work or i can t make it right, and i couldn t find similar topic any where, here is the problem. As u can see in screenshot in this link https://ibb.co/FJRBxcM i have 2 worksheets, Sheet1 with some value generator, and Sheet"RadniNalog" where i copy&paste manualy certan values from Sheet1. My goal is to make it work automatically, when i paste data from another Workbook, as shown in screenshot example, i polulate range "A10:C27", range width is constant, always 3 column, but rows can change so number is X. Now i need values from "A10:A27" to copy to next empty column from left to right in Sheet"RadniNalog" from cells in 2nd row. Next i also need to copy Value from cell =F$13$ into the first row in sheet "RadniNalog" (on screenshot example its cell "E1" and that value from F13 needs to act like a Header for values belove it. If Value from header is the same as value in cell "F13" i need to continue adding values under existing ones, and if not move to the next available column. In screenshot example, if cell "D1" from sheet "RandiNalog" is same as cell "F13" in Sheet1, then values from range "A10:A27" should be added under last value in ColumnD. I need some VBA code if possible to make it work as wanted. Thanks in advance
Copy this code to Sheet1 module
This code runs the macro copyValuesToWs when you put the code in F13
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("F13:G13")) Is Nothing Then
Application.ScreenUpdating = False
Application.EnableEvents = False
Call copyValuesToWs
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
End Sub
Create a new module and insert this code
Option Explicit
Function FindLastRow(ByVal Col As Byte, ws As Worksheet) As Long
FindLastRow = ws.Cells(Rows.Count, Col).End(xlUp).Row
End Function
Function FindLastColumn(ByVal rw As Byte, ws As Worksheet) As Long
FindLastColumn = ws.Cells(rw, Columns.Count).End(xlToLeft).Column
End Function
Sub copyValuesToWs()
Dim ws1 As Worksheet: Set ws1 = Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = Sheets("Radni nalog")
Dim lCol As Long
Dim lRow As Long
Dim srcRng As Range
Dim dstRng As Range
Dim hdRng As Range
' Next row after ID
Dim idRng As Range: Set idRng = ws1.Range("A10")
' find last row value in column A
lRow = FindLastRow(1, ws1)
' range to be copied
Set srcRng = ws1.Range(ws1.Cells(idRng.Row, 1), ws1.Cells(lRow, 1))
' find last used column in sheet2
lCol = FindLastColumn(1, ws2)
' header range
Set hdRng = ws2.Range(ws2.Cells(1, 1), ws2.Cells(1, lCol))
' check if value exists in header
On Error Resume Next
Dim sValue As Double: sValue = Application.WorksheetFunction.Match(ws1.Range("F13").Value, hdRng, 0)
If Err.Number = 0 Then ' value exists
' find last row
Set dstRng = ws2.Cells(FindLastRow(sValue, ws2) + 1, sValue)
' paste values
srcRng.Copy
dstRng.PasteSpecial xlPasteValues
Else
' set destination range
Set dstRng = ws2.Cells(2, lCol + 1)
' set header value
ws1.Range("F13:G13").Copy
ws2.Cells(1, lCol + 1).PasteSpecial xlPasteValues
' paste values
srcRng.Copy
dstRng.PasteSpecial xlPasteValues
End If
On Error GoTo 0
Application.CutCopyMode = False
End Sub
I have two questions
How to combine data using two of the cells from workbookA and copy to workbookB on the same cell?
How do I start using for loop to copy it until the last row/column?
I have no clue on how to combine the data and I do not know where to place the variable inside the code for it to loop until its last column.
Dim Tlastrow As Integer
Tlastrow = Cells(1, Columns.Count).End(xlToLeft).Column
For r = 1 To Tlastrow
Workbooks("InputB.xls").Worksheets("HC_MODULAR_BOARD_20180112").Range("F3:G3").Copy _
Workbooks("Output.xls").Worksheets("Sheet1").Range("I3")
Next
Try this:
Option Explicit
Sub Paste()
Dim wsInput As Worksheet, wsOutput As Worksheet, LastRow As Long, C As Range
Set wsInput = Workbooks("InputB.xls").Worksheets("HC_MODULAR_BOARD_20180112")
Set wsOutput = Workbooks("Output.xls").Worksheets("Sheet1")
With wsInput
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row 'Last Row with data
For Each C In .Range("F3:F" & LastRow) 'loop for every row with data
wsOutput.Cells(C.Row, "I").Value = C & " " & C.Offset(0, 1)
Next C
End With
End Sub
This code is assuming you want to paste every row from your input workbook to the output workbook on the same rows, but merging F and G columns. It's just pasting the values, not formulas or formats.
I have 6 different headers under the WIPTX worksheet that will be pulling information from the TestData tab which is essentially data that will be uploaded from a SharePoint site. I want to be able to copy and paste rows that have specific values like the type of status or by name
under each header in the WIPTX worksheet. Headers are in columns A-C, E-G, I-K, M-O, Q-S, and U-W. Headers are of different status's that are in the TestData worksheet. Status include Assigned, Accepted, In Progress, On Hold, Completed, and Cancelled.
Will this be possible?
Code that I have so far works but it does not paste under specific header columns.
I have tried researching and looing at other sources but I am still not able to find the right code that is specific to what I am looking for.
Sub Update1()
Dim LastRow1 As Long, LastRow2 As Long, i As Long
With ThisWorkbook.Worksheets("TestData")
LastRow1 = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow1
If .Range("A" & i).Value = "Thomas Xiong" Then
LastRow2 = ThisWorkbook.Worksheets("All Projects with NetBuilds").Cells(ThisWorkbook.Worksheets("All Projects with NetBuilds").Rows.Count, "A").End(xlUp).Row
.Rows(i).Copy ThisWorkbook.Worksheets("All Projects with NetBuilds").Rows(LastRow2 + 1)
End If
Next i
End With
End Sub
Is this possible?
I think this should help you:
Option Explicit
Sub Update1()
Dim wsData As Worksheet, wsProjects As Worksheet, LastRow As Long, Col As Integer, CopyRange As Range, C As Range
With ThisWorkbook
Set wsData = .Sheets("TestData") 'refering the worksheet with all the data
Set wsProjects = .Sheets("All Projects with NetBuilds") 'refering the worksheet with the headers
End With
For Each C In wsData.Range("A2", wsData.Cells(1, 1).End(xlDown)) 'Lets assume the criteria is on the column A
With wsData
Select Case C.Value
Case "Assigned"
With wsData
Set CopyRange = .Range(.Cells(C.Row, 3), .Cells(C.Row, 5)) 'Here I'm assuming you want to copy data from Columns B To D
End With
Case "Accepted"
With wsData
Set CopyRange = .Range(.Cells(C.Row, 7), .Cells(C.Row, 9)) 'Here I'm assuming you want to copy data from Columns G To I
End With
'... all your headers
End Select
End With
With wsProjects
Col = .Cells.Find(C).Column 'Find the header column
LastRow = .Cells(.Rows.Count, Col).End(xlUp).Row + 1 'find the last row on that header
CopyRange.Copy .Cells(LastRow, Col) 'paste the range (this method will copy everything from the source)
End With
Next C
'In case you are always copying the same range of cells skip the select case, delete the CopyRange variable and just copy paste on the last block
End Sub
I am new to VBA...trying to search specific columns by name and paste them into a new sheet.
What I have so far seems clunky and does not copy or paste the desired column but what I currently have on my clipboard!
Ideally I would be able to search 3 different columns and paste them on to the new sheet.
Any help would be greatly appreciated
Dim CheckText As String
Dim CheckRow As Long
Dim FindText As Range
Dim CopyColumn As String
CheckText = “Bsp” 'Bsp is an example header
CheckRow = 1 'Row with desired header
Dim oldsheet As Worksheet
Set oldsheet = ActiveSheet
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Pivot"
oldsheet.Activate
ActiveSheet.Select
'trying here to create a new sheet, name it and go back to the first sheet
Set FindText = Rows(CheckRow).Find(CheckText)
If FindText Is Nothing Then
MsgBox "Bsp not found"
End If
CopyColumn = Cells(CheckRow, FindText.Column).Column
Columns(CopyColumn).Select.Copy
Sheets("Pivot").Select
ActiveSheet.Paste
This is just a generic example that you can adjust to fit your needs. The code will look for column header named Some String. IF this column is found, we next determine the last row, copy the column (down to last row), and then paste the column in cell A1 on Pivot sheet.
Use the range variable Found to store your column header properties (namely location)
Check if the header is actually found! If Not Found is Nothing (Translation: Found)
Use Found.Column to reference the column index which fits into the Cells property nicely since the syntax is Cells(Row Index, Column Index)
Option Explicit
Sub Test()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1") '<== Sheet that has raw data
Dim LRow As Long, Found As Range
Set Found = ws.Range("A1:Z1").Find("Some String") '<== Header name to search for
If Not Found Is Nothing Then
LRow = ws.Cells(ws.Rows.Count, Found.Column).End(xlUp).Row
ws.Range(ws.Cells(1, Found.Column), ws.Cells(LRow, Found.Column)).Copy
Sheets("Pivot").Range("A1").PasteSpecial xlPasteValues '<== Sheet to paste data
End If
End Sub
You are going to want to amend some of the options on the Range.Find method. Details can be found here
I ended up using this code in an attempted to search for another header and copy and paste it
Option Explicit
Sub Test()
Dim ws As Worksheet
Set ws = ActiveSheet
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Pivot"
ws.Activate
ActiveSheet.Select
Dim LRow As Long, Found As Range
Set Found = ws.Range("A1:EM1").Find("Bsp") '<== Header name to search for
If Not Found Is Nothing Then
LRow = ws.Cells(ws.Rows.Count, Found.Column).End(xlUp).Row
ws.Range(ws.Cells(1, Found.Column), ws.Cells(LRow, Found.Column)).Copy
Sheets("Pivot").Range("A1").PasteSpecial xlPasteValues '<== Sheet to paste data
End If
ws.Activate
ActiveSheet.Select
Set Found = ws.Range("A1:EM1").Find("Sog")
If Not Found Is Nothing Then
LRow = ws.Cells(ws.Rows.Count, Found.Column).End(xlUp).Row
ws.Range(ws.Cells(1, Found.Column), ws.Cells(LRow, Found.Column)).Copy
Sheets("Pivot").Range("B1").PasteSpecial xlPasteValues
End If
End Sub