i have two workbooks- workbook 1 have own datas- and workbook2 have alot of data- the range that have data in workbook2 may change during days,it is not constant . i wanna copy non empty data from (A1:last row last cloumn that have content) in wokrbook2 to same range in workbook1- i wanna empty cells not to be copied from workbook2 to workbook1.
Sub Copy()
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim lrow As Long
Dim i As Long
Set ws = ActiveWorkbook.Worksheets("Sheet2") 'Set the name of sheet2
Set ws2 = ActiveWorkbook.Worksheets("Sheet1") 'Set the name of sheet1
lrow = ws.Cells(Rows.Count, 1).End(xlUp).Row 'Find last row in Sheet1 'Find last row in column A, for sheet 1
For i = 1 To lrow
If Not IsEmpty(ws.Cells(i, "A").Value) Then ws2.Cells(i, "A").Value = ws.Cells(i, "A").Value
Next i
End Sub
Related
I'm working with two sheets. One sheet has the full raw data while the other has a select few headers from sheet 1. If it finds a match on the header, i need it to copy the full column from sheet one to sheet 2
and it copies it to sheet 2
Here is my code so far but i can't figure out how to break the loop so that it goes through every column on sheet 1 until it finds a match:
Private Sub CommandButton1_Click()
Dim ShtOne As Worksheet, ShtTwo As Worksheet
Dim shtOneHead As Range, shtTwoHead As Range`enter code here`
Dim headerOne As Range, headerTwo As Range
Set ShtOne = Sheets("Sheet1")
Set ShtTwo = Sheets("Sheet2")
'row count
Dim b As Long
b = ShtOne.Cells(Rows.Count, 1).End(xlUp).Row
'column count in sheet 1
Dim a As Long
a = ShtOne.Cells(1, Columns.Count).End(xlToLeft).Column
'column count in sheet 2
Dim c As Long
c = ShtTwo.Cells(1, Columns.Count).End(xlToLeft).Column
Dim lastCol As Long
'get all of the headers in the first sheet, assuming in row 1
lastCol = ShtOne.Cells(1, Columns.Count).End(xlToLeft).Column
Set shtOneHead = ShtOne.Range("A1", ShtOne.Cells(1, lastCol))
'get all of the headers in second sheet, assuming in row 1
lastCol = ShtTwo.Cells(1, Columns.Count).End(xlToLeft).Column
Set shtTwoHead = ShtTwo.Range("A1", ShtTwo.Cells(1, lastCol))
'stops the visual flickering of files opening and closing - run at the background
Application.ScreenUpdating = False
'start loop from first row to last row
'For i = 1 To a
i = 1
j = 0
'actually loop through and find values
For Each headerOne In shtOneHead
j = j + 1
For Each headerTwo In shtTwoHead
'copy and paste each value
If headerTwo.Value = headerOne.Value Then
'copies one row at a time (a bit slow)
' headerOne.Offset(i, 0).Copy
' headerTwo.Offset(i, 0).PasteSpecial xlPasteAll
'copies whole rows at a time
ShtOne.Columns(i).Copy ShtTwo.Columns(j)
i = i + 1
Application.CutCopyMode = False
Exit For
End If
Next headerTwo
Next headerOne
'Next
End Sub
Assuming your headers are on row 1 for both sheets and that you will always be pasting on the second row on Sheet2.
Only loop through your column headers on the second sheet. Use Range.Find to search for each header on Sheet1. If the header is found, copy and paste accordingly
Sub Headerz()
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet2")
Dim LC As Long, i As Long, LR As Long
Dim Found As Range
LC = ws2.Cells(1, ws2.Columns.Count).End(xlToLeft).Column
For i = 1 To LC
Set Found = ws1.Rows(1).Find(ws2.Cells(1, i).Value)
If Not Found Is Nothing Then
LR = ws1.Cells(ws1.Rows.Count, Found.Column).End(xlUp).Row
ws1.Range(ws1.Cells(2, Found.Column), ws1.Cells(LR, Found.Column)).Copy
ws2.Cells(2, i).PasteSpecial xlPasteValues
End If
Set Found = Nothing
Next i
End Sub
I am trying to add a button, that adds a new column after the last column with values. This works.
Now I want to copy values to the new column. Values shall be copied from the last column from row 32 to the last one with a value in column A.
Right now Ihave a code for copying the whole column. How do I concentrate on the specific range?
Sub AddMeeting()
Dim ws As Worksheet
Dim lastcol As Long
Set ws = ActiveSheet
lastcol = ws.Cells(32, ws.Columns.Count).End(xlToLeft).Column
Columns(lastcol).Copy Destination:=Columns(lastcol + 1)
Range ((Cells.Columns.Count.End(xlLeft)) & Range(32)), (lastcol + 1) & Cells.Rows.Count.End(xlUp)
Application.CutCopyMode = False
End Sub
Values shall be copied from the last column from row 32 to the last one with a value in column A
Is this what you are trying?
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, lCol As Long
Dim LastColumn As String
Dim rngToCopy As Range
'~~> Set this to the relevant worksheet
Set ws = Sheet1
With ws
'~~> Find last row in Col A
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Find last column in row 32
lCol = .Cells(32, .Columns.Count).End(xlToLeft).Column
'~~> Get Column Name from column number
' https://stackoverflow.com/questions/10106465/excel-column-number-from-column-name
LastColumn = Split(Cells(, lCol).Address, "$")(1)
Set rngToCopy = .Range("A32:" & LastColumn & lRow)
Debug.Print rngToCopy.Address
With rngToCopy
'
' Do what you want here
'
End With
End With
End Sub
I have a floating button which when I have selected some rows and presses the button I want some specified cells from the selected rows to be copied and then pasted into a other workbook which opens when button is pressed.
For example the value in Column A rows 2-3 is selected and when I press the button I want the values in column A from the selected rows to be copied to column B from start of row 2. The values in column E to be copied to column F etc.
I have found following code but I can't find out how to modify the code to specify what cells to copy to where.
Anyone out there to give me some hints?
Sub CopyCells()
Dim Rng As Range
For Each Rng In Selection.Areas
Union(Rng.Resize(, 6), Rng.Resize(, 1).Offset(, 1)).Copy Sheets("Blad2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 5)
Next Rng
Worksheets("Blad2").Activate
End Sub
New code:
Public Sub CopyCells()
Dim wsSrc As Worksheet 'define source sheet
Set wsSrc = ThisWorkbook.Worksheets("Sheet1")
Dim wsDest As Worksheet 'define destination sheet
Dim wbDest As Workbook 'define destination workbook
Set wbDest = Workbooks.Open("C:\Temp\Test.xlsx")
Set wsDest = wbDest.Worksheets("Sheet1")
Dim DestRow As Long
DestRow = 2 'start in row 2 in destination sheet
Dim Rng As Range
For Each Rng In Selection.Areas
Rng.Resize(, 1).Copy Destination:=wsDest.Cells(DestRow, "B") 'copy A to B
Rng.Resize(, 1).Offset(, 4).Copy Destination:=wsDest.Cells(DestRow, "F") 'copy E to F
DestRow = DestRow + Rng.Rows.Count 'move DestRow to next free row
Next Rng
End Sub
You need a copy action for each column if the columns are not continous.
Option Explicit
Public Sub CopyAtoBandEtoF()
Dim wsSrc As Worksheet 'define source sheet
Set wsSrc = ThisWorkbook.Worksheets("Source")
Dim wsDest As Worksheet 'define destination sheet
Set wsDest = ThisWorkbook.Worksheets("Destination")
Dim DestRow As Long
DestRow = 2 'start in row 2 in destination sheet
Dim Rng As Range
For Each Rng In Selection.Areas
Rng.Resize(, 1).Copy Destination:=wsDest.Cells(DestRow, "B") 'copy A to B
Rng.Resize(, 1).Offset(, 4).Copy Destination:=wsDest.Cells(DestRow, "F") 'copy E to F
DestRow = DestRow + Rng.Rows.Count 'move DestRow to next free row
Next Rng
End Sub
I have 2 worksheets. sheet1 is monthly Value on col A. Sheet 2 is daily value on col A, I would Like Excel to look for the same value in worksheet 2 (Daily), then once it finds that exact value, to copy the matched rows form sheet 1 (monthly) and paste it in sheet 2 (Daily).
Any ideas how to write a VBA code that will automate this copy and paste values process? (see the screenshot)
[1]: https://i.stack.imgur.com/G5LqW.png
[on the right handside, data is per month (last day of each month), i need to match col Aof both sheets, and bring the data to other sheet on exact day (last day of that month)][1]
Untested
Sub Copy18()
Dim wb As Workbook
Dim wsD2 As worksheet, wsM2 As Worksheets
Dim LastRow As long, LastCol As Long, i as long
Dim Cell As Range, Rng As Range, SearchR As Range, CopyRng As Range, PasteRng As Range
Set wb = ThisWorkbook
Set wsD2 = wb.Sheets("Daily-2")
Set wsM2 = wb.Sheets("Monhly-2")
LastCol = wsM2.Cells(1, Columns.Count).End(xlToLeft).Column
LastRow = wsM2.Cells(Rows.Count, 1).End(xlUp).Row
Set Rng = wsD2.Range(wsD2.Cells(1,1), wsD2.Cells(LastRow, LastCol))
For Each Cell in Rng
Set SearchR = wsM2.Range("A:A").Find(Cell.Value, LookAt:=xlWhole)
If Not SearchR Is Nothing Then
i = LastCol = wsM2.Cells(SearchR.Row, Columns.Count).End(xlToLeft).Column
Set CopyRng = wsM2.Range(wsM2.Cells(SearchR.Row, 1), wsM2.Cells(SearchR.Row, i))
Set PasteRng = wsD2.Range(wsD2.Cells(LastRow + 1, 1), wsD2.Cells(LastRow + 1, i))
PasteRng.Value = CopyRng.Value
LastRow = LastRow + 1
End If
Next Cell
End Sub
currently the code below will copy two spreadsheets into the macro sheet.
Problem: I want to use Excel cells to specify a file path (from cell A1, A2 or wherever), a sheet name (from cell B1, B2), and a corresponding specified cell range (in cells C1, C2) instead of having to browse to each file with the Application.
Option Explicit
Sub Sample()
Dim wb1 As Workbook: Set wb1 = ThisWorkbook
Dim wb2 As Workbook
Dim i As Long
Dim wsNew As Worksheet
Dim ws As Worksheet: Set ws = wb1.Sheets("Sheet1")
Dim LastRow
Dim sheetName As String
Dim rangeStart As String
Dim rangeEnd As String
Dim ws2 As Worksheet
Dim CellValueToCopy As String
'declare and set your worksheet with your filenames
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get the last row with data by finding the last item in Column A
For i = 2 To LastRow 'loop from Row 2 to Last in Sheet1 of this workbook
Set wb2 = Workbooks.Open(ws.Cells(i, "A")) 'open the file stored in Column A of Sheet1 of this workbook
sheetName = ws.Cells(i, "B")
rangeStart = ws.Cells(i, "C")
rangeEnd = ws.Cells(i, "D")
'wb2.Sheets(ws.Cells(i, "B").Value).range(ws.Cells(i, "C").Value).Copy
Set ws2 = wb2.Worksheets(sheetName)
wb1.Sheets.Add
wb1.ActiveSheet.Name = sheetName + "_added"
' the below is a proof of concept to copy the values
' loop through the range rather than just one cell to get the final copy
CellValueToCopy = ws2.Cells(1, 1)
wb1.ActiveSheet.Cells(1, 1) = CellValueToCopy
' close workbook and reset variables
wb2.Close SaveChanges:=False
Set wb2 = Nothing
Set wsNew = Nothing
Set ws2 = Nothing
Next i
End Sub
How about something like the following, this will loop through your column A, open the given filename, and copy the Range from Column C from the Sheet in Column B and paste into a new sheet in the current workbook:
Option Explicit
Sub Sample()
Dim wb1 As Workbook: Set wb1 = Workbooks("Change from interface to Cell specify range.xlsm")
Dim wb2 As Workbook
Dim i As Long, LastRow As Long
Dim wsNew As Worksheet
Dim ws As Worksheet: Set ws = wb1.Sheets("Sheet1")
'declare and set your worksheet with your filenames, amend as required
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A
For i = 2 To LastRow 'loop from Row 2 to Last in Sheet1 of this workbook
Set wb2 = Workbooks.Open(ws.Cells(i, "A")) 'open the file stored in Column A of Sheet1 of this workbook
wb2.Sheets(ws.Cells(i, "B").Value).Range(ws.Cells(i, "C").Value).Copy
'above specify the sheet from Column B of Sheet1 and the Range from Column C
'if you have starting range at Column C and end range at Column D then the line below will copy the specified range
'wb2.Sheets(ws.Cells(i, "B").Value).Range(ws.Cells(i, "C").Value & ":" & ws.Cells(i, "D").Value).Copy
Set wsNew = wb1.Sheets.Add(After:=wb1.Sheets(wb1.Sheets.Count))
wsNew.Name = "Blah Blah " & (i - 1)
'above add a new sheet and name accordingly, I used the counter i to number the sheets
wsNew.Range("A1").PasteSpecial xlPasteAll
wb2.Close SaveChanges:=False
Set wb2 = Nothing
Set wsNew = Nothing
Next i
End Sub