I am stuck. I have corresponding data on two sheets. I want to go down the rows in sheet1, use the value in column M, find the matching value in sheet3 column M, then copy the data into sheet1. Sheet1 is 4000 lines. My copy logic is working, unfortunately, my loop does not end and it copies row1 until excel freezes. Any assistance is greatly appreciated - obviously I am still a VBA novice.
Dim searchTerm As String
Dim r As Long
For i = 1 To 4000
searchTerm = Worksheets("Sheet1").Range("M" & i).Text
If Worksheets("Sheet1").Range("M" & i).Value = searchTerm Then
'Select row in Sheet1 to copy
Worksheets("Sheet3").Select
Range("A" & i & startcolumn & ":AU" & i & lastcolumn).Select
Selection.Copy
'Paste row into Sheet2 in next row
Sheets("Sheet1").Select
Columns("AX").Select
ActiveSheet.Paste
'Move counter to next row
'Go back to Sheet1 to continue searching
Sheets("Sheet1").Select
End If
Next i
A VBA Lookup
The following will loop through each cell in range "M1:M4000" of worksheet "Sheet1" and try to find each cell's value in column "M" of "Sheet3". If found, the values from columns "A" to column "AU" in the found row of worksheet "Sheet3" will be copied to worksheet "Sheet1", to the same sized row range starting with column "AX".
The Code
Option Explicit
Sub SimpleLookup()
' Define workbook.
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
' Destination
' Define Destination Worksheet.
Dim dst As Worksheet
Set dst = wb.Worksheets("Sheet1")
Dim lValue As Variant ' Lookup Value
Dim i As Long ' Destination Rows Counter
' Source
' Define Source Worksheet.
Dim src As Worksheet
Set src = wb.Worksheets("Sheet3")
' Define Copy Range.
Dim cRng As Range
Set cRng = src.Range("A1:AU4000")
' Define Lookup Column Range.
Dim lRng As Range
Set lRng = cRng.Columns(13)
Dim rRng As Range ' Current Copy Row Range
Dim lIndex As Variant ' Lookup Index
' Loop
' Loop through rows (cells) of Criteria Column Range.
For i = 1 To 4000
' Write the value of the current cell to a variable, Lookup Value.
lValue = dst.Cells(i, "M").Value
' Define Lookup Index, the index (row) where the Lookup value
' was found in Lookup Column Range.
lIndex = Application.Match(lValue, lRng, 0)
' Evaluate Lookup Index: it will be an error value if not found.
If Not IsError(lIndex) Then
' Define Current Copy Row Range.
Set rRng = cRng.Rows(lIndex)
' Either...:
' Values only.
' Copy Current Copy Row Range to Destination Worksheet.
dst.Cells(i, "AX").Resize(, rRng.Columns.Count).Value = rRng.Value
' ...Or:
' Values, formulas, formats.
'rRng.Copy Destionation:=dst.Cells(i, "AX")
End If
Next i
End Sub
Related
I want to get all values (not empty) of first row of excel .
oBook.Sheets("Sheet1").Rows(1).End(xlDown).column
but I think this is wrong.
I want to loop it and show value inside a MsgBox.
Loop Through the Cells of the Header Row
Dim ws As Worksheet: Set ws = oBook.Sheets("Sheet1")
Dim hrg As Range
Set hrg = ws.Range("A1", ws.Cells(1, ws.Columns.Count).End(xlToLeft))
Dim hCell As Range
For Each hCell In hrg.Cells
MsgBox hCell.Address(0, 0) & " = " & hCell.Value
Next hCell
as per your wording, you need "all values (not empty) of first row of excel" sheet.
you can then use:
WorksheetFunction.CountA() function to count the number of not empty
cell in a range
SpecialCells() method of Range object to select not empty cells
as follows:
With oBook ' reference your workbook
With .Worksheets("Sheet1") ' reference "Sheet1" worksheet of referenced workbook
With .Range("A1", .Cells(1, .Columns.Count).End(xlToLeft)) ' reference row 1 range from column 1 rightwards to last not empty cell in referenced worksheet
If WorksheetFunction.CountA(.Cells) > 0 Then ' if at least one not empty cell
Dim cel As Range
For Each cel In .SpecialCells(XlCellType.xlCellTypeConstants) ' loop thorugh referenced range not empty cells
Debug.Print cel.Value
Next
End If
End With
End With
End With
i am very new to vba , currently i am looking for code to copy cell values from list to multiple sheet in specific cell
what i am trying to do is as per bellow sheet "point" i have a list with values column B are the names and C & D are values
i need to copy sheet named "template" and rename as per the values in Column B and the values are un defined and be upto any length
list sheet
template
currently i am using bellow code to copy sheet and rename as per list
Sub CopySheetRenameFromCell()
Dim sh1 As Worksheet, sh2 As Worksheet, c As Range
Set sh1 = Sheets("template")
Set sh2 = Sheets("point")
For Each c In sh2.Range("B6", sh2.Cells(Rows.Count, 2).End(xlUp))
sh1.Copy After:=Sheets(Sheets.Count)
On Error Resume Next
ActiveSheet.Name = c.Value:
On Error GoTo 0
Next
End Sub
result sheet
but i have no idea how can i copy value from "point" Sheet Column C and D values 1 & 51 to sheet "a" Column C2 and F2 and so on
a values in sheet "a"
b values in sheet "b" and on
awaiting your help
Copy Template Worksheet
This is a basic code. It assumes that each of the cells of the range B6:BLastRow contains a valid value for naming a worksheet. It also assumes that each of the worksheets to be created does not exist already.
Option Explicit
Sub CopySheetRenameFromCell()
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source worksheet ('sws').
Dim sws As Worksheet: Set sws = wb.Worksheets("Point")
' Calculate the source last row ('slRow'),
' the row of the last non-empty cell in the column.
Dim slRow As Long
slRow = sws.Cells(sws.Rows.Count, "B").End(xlUp).Row
' Reference the template worksheets ('tws').
Dim tws As Worksheet: Set tws = wb.Worksheets("Template")
' Declare additional variables.
Dim dws As Worksheet ' Current Destination (Copied) Worksheet
Dim sr As Long ' Current Row in the Source Worksheet
' Loop through the rows of the source worksheet.
For sr = 6 To slRow
' Create a copy of the template worksheet after the last sheet
' in the workbook.
tws.Copy After:=wb.Sheets(wb.Sheets.Count)
' Reference this copy, the destination worksheet,
' which is the last (work)sheet in the workbook.
Set dws = wb.Sheets(wb.Sheets.Count)
' Rename the destination worksheet.
dws.Name = sws.Cells(sr, "B").Value
' Write the values from columns 'C' and 'D' in the row ('r')
' of the source worksheet to the cells `C2` and `F2` respectively
' in the destination worksheet.
dws.Range("C2").Value = sws.Cells(sr, "C").Value
dws.Range("F2").Value = sws.Cells(sr, "D").Value
Next sr
' Save the workbook.
'wb.Save
' Inform.
MsgBox "Point worksheets created.", vbInformation
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 an excel file with over 200 sheets + index sheet, and I am trying to go through all sheets to copy data from index sheet. For example, I have the below table:
A test1
B test2
C test3
D test4
So I would like to do a vlookup in the index sheet, and copy the column K into the right sheet. For example, I would like "test1" to be copied in sheet "A", in cell A3. The table to vlookup is in sheet "INDEX", range J1:K4.
Is that possible? I stored a file here! For confidentiality reason, I've edited sheet names and content, and put a shorter file.
Thanks in advance!
Update Worksheets
Option Explicit
Sub updateWorksheets()
' Define constants.
Const wsName As String = "INDEX"
Const FirstCellAddress As String = "J1"
Const dstAddress As String = "A3"
Dim wb As Workbook: Set wb = ThisWorkbook ' Workbook containing this code.
' Define Data Range.
Dim rng As Range
With wb.Worksheets(wsName).Range(FirstCellAddress).Resize(, 2)
Set rng = .Resize(.Worksheet.Rows.Count - .Row + 1).Find( _
What:="*", _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious)
If rng Is Nothing Then
Exit Sub
End If
Set rng = .Resize(rng.Row - .Row + 1)
End With
' Write values from Data Range to Data Array.
Dim Data As Variant: Data = rng.Value
' Declare additional variables (to be used in the 'For Next' loop).
Dim dst As Worksheet ' Current Destination Worksheet
Dim i As Long ' Data Array Row Counter
' Loop through rows of Data Array.
For i = 1 To UBound(Data, 1)
' Use the value in the first column to try to create a reference
' to the worksheet i.e. check if the worksheet exists.
Set dst = Nothing
On Error Resume Next
Set dst = wb.Worksheets(Data(i, 1))
On Error GoTo 0
' If the worksheet exists,...
If Not dst Is Nothing Then
' ...write value from second column of Data Array
' to Destination Cell Range in Current Destination worksheet.
dst.Range(dstAddress).Value = Data(i, 2)
End If
Next i
End Sub
I have 2 workbook i.e workbook A and Workbook B
A workbook having column in order A,B,C,D and B workbook having Column D,C,B,A.
I have to insert A workbook data into B workbook in proper column that is the columns inserted into proper column A in A ,B in B, C in C, D in D
I tried below code
Sub DEMO()
For i = 1 To 4
For j = 2 To 4
For k = 2 To 4
If Sheets(1).Cells(i, j).Value = Sheets(2).Cells(i, j).Value Then
Sheets(2).Cells(k, j).Value = Sheets(1).Cells(j, i).Value
End If
Next k
'MsgBox Sheets(1).Cells(2, 1).Value
'MsgBox Sheets(2).Cells(2, 1).Value
Next j
Next i
End Sub
Please help on this
To match the column names of …
Worksheet A
with the column names in …
Worksheet B
Use a loop and the WorksheetFunction.Match method
Option Explicit
Sub MatchColumns()
Dim wsA As Worksheet 'define worksheet A
Set wsA = ThisWorkbook.Worksheets("A")
Dim ColsRangeA As Range 'get column names in A
Set ColsRangeA = wsA.Range("A1", wsA.Cells(1, wsA.Columns.Count).End(xlToLeft))
Dim wsB As Worksheet 'define worksheet B
Set wsB = ThisWorkbook.Worksheets("B")
Dim ColsRangeB As Range 'get column names in B
Set ColsRangeB = wsB.Range("A1", wsB.Cells(1, wsB.Columns.Count).End(xlToLeft))
Dim MatchedColNo As Long
Dim Col As Range
For Each Col In ColsRangeA 'loop throug column names in A
MatchedColNo = 0 'initialize
On Error Resume Next 'test if column name can be found in worksheet B column names
MatchedColNo = Application.WorksheetFunction.Match(Col.Value, ColsRangeB, False)
On Error GoTo 0
If MatchedColNo <> 0 Then 'if name was found
wsB.Cells(2, MatchedColNo).Value = "Matches wsA col " & Col.Column
Else 'if name didn't match
MsgBox "no maching column found for " & Col.Value
End If
Next Col
End Sub
Copy Below Headers
The Code
'*******************************************************************************
'Purpose: Copies the values below headers from one worksheet
' to another containing the same headers.
'*******************************************************************************
Sub CopyBelowHeaders()
' !!! Header List !!! Change this to any comma separated string containing
' the values of the headers e.g. "ID, Product,Count, Price,Stock ".
Const cHeaders As String = "A,B,C,D"
Const cSource As String = "Sheet1" ' Source Worksheet Name
Const cTarget As String = "Sheet2" ' Target Worksheet Name
Const cFirstR As Long = 2 ' First Row Number
Dim rngS As Range ' Current Source Header Cell Range,
' Current Source Column Last Used Cell Range,
' Current Source Column Range
Dim rngT As Range ' Current Target Header Cell Range,
' Current Target Column Range
Dim vntH As Variant ' Header Array
Dim vntS As Variant ' Source Header Column Array
Dim vntT As Variant ' Target Header Column Array
Dim i As Long ' Header Arrays Element Counter
vntH = Split(cHeaders, ",") ' Write Header List to Header Array.
ReDim vntS(UBound(vntH)) As Long ' Resize Source Header Column Array.
ReDim vntT(UBound(vntH)) As Long ' Resize Target Header Column Array.
' Column Numbers to Column Arrays
' In Source Worksheet
With ThisWorkbook.Worksheets(cSource)
' Loop through elements of Header Array.
For i = 0 To UBound(vntH)
' In Source Row Range (Header Row, 1st Row)
With .Rows(1)
' Find current element (string) of Header Array
' in Source Row Range.
Set rngS = .Find(Trim(vntH(i)), .Cells(.Cells.Count), _
xlValues, xlWhole, xlByRows, xlNext)
' When current element was found, write column number to
' Source Header Columns Array.
If Not rngS Is Nothing Then vntS(i) = rngS.Column
End With
Next
End With
' In Target Worksheet
With ThisWorkbook.Worksheets(cTarget)
' Loop through elements of Header Array.
For i = 0 To UBound(vntH)
' In Target Row Range (Header Row, 1st Row)
With .Rows(1)
' Find current element (string) of Header Array
' in Target Row Range.
Set rngT = .Find(Trim(vntH(i)), .Cells(.Cells.Count), _
xlValues, xlWhole, xlByRows, xlNext)
' When current element was found, write column number to
' Source Header Columns Array.
If Not rngS Is Nothing Then vntT(i) = rngT.Column
End With
Next
End With
' Source Worksheet to Target Worksheet
' In Source Worksheet
With ThisWorkbook.Worksheets(cSource)
' Loop through elements of Source Array.
For i = 0 To UBound(vntS)
' When current element of Source Header Column Array and current
' element of Target Header Column Array are different than "".
If vntS(i) > 0 And vntT(i) > 0 Then
' Find Last Used Cell Range in current Source Column Range.
Set rngS = .Columns(vntS(i)).Find("*", , xlFormulas, _
xlWhole, xlByColumns, xlPrevious)
' When current Source Column is not empty.
If Not rngS Is Nothing Then
' When current Source Column contains data in at least
' one more row than the Source Header row.
If rngS.Row > 1 Then
' Calculate Source Column Range.
Set rngS = .Range(.Cells(cFirstR, vntS(i)), rngS)
' In First Cell of Target Column Range
With ThisWorkbook.Worksheets(cTarget) _
.Cells(cFirstR, vntT(i))
' Clear contents in Target Column Range from
' First Cell to bottom cell.
.Resize(Rows.Count - cFirstR + 1).ClearContents
' Resize Current Target Column Range to the size
' of Current Source Column Range.
Set rngT = .Resize(rngS.Rows.Count)
End With
' Copy values from Current Source Column Range to
' Current Target Column Range.
rngT = rngS.Value
End If
End If
End If
Next
End With
End Sub