I am trying to select a subset of data in a range and copy it to another sheet in Excel. My thought process was as follows
Find the first and last instance of the value in a column
Copy from the first instance down to the last instance and all the way to the Right
Paste the range of data into my sheet
I am having trouble finding the first and last instance of the value in a column and setting the range to copy.
This is what I have so far:
Sub Button()
'Application.ScreenUpdating = False
Dim wb As Workbook
Dim ws_temp, ws_data As Worksheet
Dim data_rng As Range
Set wb = ThisWorkbook
Set ws_temp = wb.Sheets("Template")
Set ws_data = wb.Sheets("data")
'declare id
Dim id As Integer
Set id= ws_temp.Range("B4").Value 'this is where the value is stored
'find first instance of id in data.
' The data starts in cell A6 and extends to column O. The number of rows will be variable
'find last instance of pitcher id
'Set data_rng
Set data_rng = wb.ws_data.Range("first instance":O&"second instance")
'Copy data_rng
data_rng.Copy wb.ws_temp.Range("A8") 'the data will always go in cell A8 on the Template sheet
'Application.ScreenUpdating = True
End Sub
What you could do is use Application.Match to find the row of the first instance then use Application.CountIf to count the no of occurrences of the search term.
With that information you should be able to get the subset of the data you want to copy using Resize.
Sub Button()
Dim wb As Workbook
Dim ws_temp, ws_data As Worksheet
Dim data_rng As Range
Dim id As Long
Dim lngFirstRow As Long
Dim lngNoRows As Long
Application.ScreenUpdating = False
Set wb = ThisWorkbook
Set ws_temp = wb.Sheets("Template")
Set ws_data = wb.Sheets("data")
' get search id
id = ws_temp.Range("B4").Value
' find row of first occurence of id
lngFirstRow = Application.Match(id, ws_data.Columns(2), 0)
' find count of id
lngNoRows = Application.CountIf(ws_data.Columns(2), id)
Set data_rng = ws_data.Range("B" & lngFirstRow).Resize(lngNoRows, 14)
'Copy data_rng
data_rng.Copy ws_temp.Range("A8") 'the data will always go in cell A8 on the Template sheet
Application.ScreenUpdating = True
End Sub
Related
I have a large sheet of data:
Updated Data
where i need to copy only a speacific part of this data to another worksheet:
The data i need to copy is always 4 cells wide however can be at any row and column. The first column cell at the top will allways be the same text value and i need to copy then from that found cell, 4 cells across to the right and then down to the cells are empty. All subsequent ranges after the first will use the same columns have several empty cells bother above and below each range needed. The macro will be run using a "button" so doesn't need to be checking the value of the cell all the time. The images are simplified versions of the data but are very accurate. 0 is used to show data surrounding range, HELLO is the data inside the range and INT_EXT_DOOR is my searched for cell value which can be in any column between data sets but will be the same inside each data set. The first range always starts at row 2.
Each range has to be numbered, defined by another worksheets cell value. For example, if my cell value is 1 i need it to copy range 1, if my value is 2 copy range 2 ect.
I have been trying to no luck to get anything that works like needed and would appreciate any help, thanks.
Test the next function, please:
Private Function testReturnBlock(strBlock As String, blkNo As Long)
Dim sh As Worksheet, ws As Worksheet, lastRow As Long, searchC As Range
Dim rng As Range
Set sh = ActiveSheet ' use here your sheet to be processed
Set ws = Worksheets("Return") 'use here your sheet where the data will be returned
Set searchC = sh.UsedRange.Find(strBlock)
If searchC Is Nothing Then MsgBox "No such a field in the worksheet...": Exit Function
lastRow = sh.Cells(Rows.Count, searchC.Column).End(xlUp).row
'The following part works well only if the blocks are separated by empty rows, as you said it is your sheet data case...
Set rng = sh.Range(searchC, sh.Cells(LastRow, searchC.Column)).SpecialCells(xlCellTypeConstants)
ws.Range("A1").Resize(rng.Areas(blkNo).Rows.Count, 4).Value = rng.Areas(blkNo).Resize(, 4).Value
End Function
The above function should be called like this:
Sub testRetBlock()
testReturnBlock "INT_EXT_DOOR", 2
End Sub
But in order to see that the correct range has been returned, you must adapt them in a way (in your test sheet), do differentiate. I mean the second one to contain "HELLO1" (at least on its first row), the following "HELLO2" and so on...
Try this routine if it does what you need. otherwise it should be a good start for adding whatever you need on top.
Option Explicit
Sub CopyBlock()
Dim wb As Excel.Workbook
Dim wsSource As Excel.Worksheet
Dim wsDest As Excel.Worksheet
Dim wsSelect As Excel.Worksheet
Dim lBlockNo As Long
Dim strCellID As String
Dim lBlock As Long
Dim lRow As Long
Dim lBlockRow As Long
Dim lBlockCol As Long
Dim searchRange As Excel.Range
Dim bRange As Excel.Range
Dim cRange As Excel.Range
Set wb = ActiveWorkbook
' set the worksheet objects
Set wsSource = wb.Sheets("Source")
Set wsDest = wb.Sheets("Dest")
Set wsSelect = wb.Sheets("Select") ' here you select which block you want to copy
' Identifier String
strCellID = "INT_EXT_DOOR"
' Which block to show. We assume that the number is in cell A1, but could be anywhere else
lBlockNo = wsSelect.Range("A1")
lRow = 1
' Find block with lBlockNo
For lBlock = 1 To lBlockNo
' Search the identifier string in current row
Do
lRow = lRow + 1
Set searchRange = wsSource.Rows(lRow)
Set bRange = searchRange.Find(strCellID, LookIn:=xlValues)
Loop While (bRange Is Nothing)
Next lBlock
lBlockRow = bRange.Row
lBlockCol = bRange.Column
' Search the first with empty cell
Do
lRow = lRow + 1
Loop While wsSource.Cells(lRow, lBlockCol) <> ""
' Copy the range found into the destination sheet
Range(Cells(lBlockRow, lBlockCol), Cells(lRow - 1, lBlockCol + 3)).Copy wsDest.Range("A1")
' Note the block copied
wsDest.Cells(1, 6) = "Block No:"
wsDest.Cells(1, 8) = lBlockNo
' Clean up (not absolutely necessary, but good practice)
Set searchRange = Nothing
Set bRange = Nothing
Set cRange = Nothing
Set wsSource = Nothing
Set wsDest = Nothing
Set wsSelect = Nothing
Set wb = Nothing
End Sub
Let me know if you need more help
I am trying to create a VBA module, that takes data from a table in one worksheet and copies it to a second worksheet. This second worksheet should then be exported as a PDF.
The exporting part and naming the PDF is not an issue and I will only tackle this when the copying of the data from one sheet to the other works.
The structure of the table is that I have several rows that have data relevant to the invoice I want to fill on the second sheet and I would like that the macro loops through the whole file and only takes what it needs, but for now I am working on an easier version where I simply want to copy the data from a selection.
Option Explicit
Sub InvoiceCreator()
'create sheet
'Add info to sheet'
'save invoice sheet as PDF with name of customer
'reset sheet
'insert i+1 dataset
'loop til end
Dim sWS As Worksheet
Dim dWS As Worksheet
Dim sRange As Range
Dim sBNR As Range
Dim dBNR As Range
Dim sKNR As Range
Dim dKNR As Range
Dim sREF As Range
Dim dREF As Range
Dim sPRT As Range
Dim dPRT As Range
Dim sDAT As Range
Dim dDAT As Range
Dim sADR As Range
Dim dADR As Range
Dim sDES As String
Dim dDES As String
'Dim sPRC As Range
'Dim dPRC As Range
Dim i As Integer
Dim lastrow As Long
Set sWS = Sheets("Data")
Set dWS = Sheets("Sheet1")
Set sRange = Selection
Set sBNR = sRange.Cells(2, 7)
Set dBNR = dWS.Range("E4")
dBNR = sBNR.Value
Set sKNR = sRange.Cells(2, 2)
Set dKNR = dWS.Range("E6")
dKNR = sKNR.Value
Set sREF = sRange.Cells(2, 22)
Set dREF = dWS.Range("E8")
dREF = sREF.Value
Set sPRT = sRange.Cells(2, 23)
Set dPRT = dWS.Range("E10")
dPRT = sPRT.Value
Set sDAT = sRange.Cells(2, 4)
Set dDAT = dWS.Range("F4")
dDAT = sDAT.Value
lastrow = sRange.End(xlUp).Row
For i = 2 To lastrow
sDES = sRange.Cells(i, 12)
dDES = dWS.Range("A" & i + 23)
dDES = sDES
Next i
End Sub
Most of the code works and copies values from one sheet to the other, but I am stuck with the last loop bit.
I want to take the value of the string in a cell and copy it to a cell in the other sheet and then copy the cell value of the cell below and copy it to the other worksheet one cell below until the end of my selection. I am not getting any error, but it is not copying the data.
Any advice?
I am working on a code to copy data to Workbook 1 (Main Workbook) from Workbook 2 based on a criteria.
The criteria is - If the value of cell C11 in Workbook 1 (Main Workbook) is equal to column A of Workbook 2, then copy all the data from Workbook 2 columns A to F to Workbook 1 (Main Workbook). Please note that there could be multiple matching values (in Workbook 2) that may need to be copied to Workbook 1.
I have tried the below code that pull all the data perfectly. Now I am trying to see if there is a code which can be applied to copy data based on criteria.
Private Sub CommandButton1_Click()
' Get Tiger calendar workbook...
Dim customerBook As Workbook
Dim filter As String
Dim caption As String
Dim customerFilename As String
Dim customerWorkbook As Workbook
Dim targetWorkbook As Workbook
' make weak assumption that active workbook is the target
Set targetWorkbook = Application.ActiveWorkbook
' get the Tiger calendar workbook
filter = "Text files (*.xlsx),*.xlsx"
caption = "Please Select the Tiger Calendar file"
customerFilename = Application.GetOpenFilename(filter, , caption)
Set customerWorkbook = Application.Workbooks.Open(customerFilename)
' assume range is A1 - M10000 in sheet1
' copy data from Tiger calendar to target workbook
Dim targetSheet As Worksheet
Set targetSheet = targetWorkbook.Worksheets("Sheet1")
Dim sourceSheet As Worksheet
Set sourceSheet = customerWorkbook.Worksheets(1)
targetSheet.Range("B14", "G500").Value = sourceSheet.Range("A2", "G500").Value
' Close customer workbook
customerWorkbook.Close
End Sub
For example, if Cell C11 in Workbook 1 = 1232223 (Product ID), then the data copied should be all the sales details related to the product ID. The bulk data is available in Workbook 2.
Who Is Who, What Is What
In this workbook check cell C11 against the values in source workbook's A column. When found, copy the range of the row and 6 contiguous columns (A-F) to this workbook starting from B14 (B-G). Do all of this until the last row of data in source workbook is reached.
Private Sub CommandButton1_Click()
Const filter As String = "Text files (*.xls*),*.xls*"
Const caption As String = "Please Select the Tiger Calendar file"
Const wsTarget As Variant = "Sheet1" ' Target Worksheet Name/Index
Const cTgtFirst As String = "B14" ' Target First Cell Range
Const cTgtSearch As String = "C11" ' Target Search Value Cell Range
Const wsSource As Variant = 1 ' Source Worksheet Name/Index
Const cSrcFirst As Long = 2 ' Source First Row
Const cSrcFirstCol As Variant = "A" ' Source First Column Letter/Number
Const cColumns As Integer = 6 ' Number of Columns
Dim customerFilename As String
Dim sourceSheet As Worksheet
Dim i As Long
Dim rngTarget As Range
customerFilename = Application.GetOpenFilename(filter, , caption)
Set sourceSheet = Workbooks.Open(customerFilename).Worksheets(wsSource)
With sourceSheet
Set rngTarget = ThisWorkbook.Worksheets(wsTarget).Range(cTgtFirst)
For i = cSrcFirst To .Cells(.Rows.Count, cSrcFirstCol).End(xlUp).Row
If .Cells(i, cSrcFirstCol) = rngTarget.Parent.Range(cTgtSearch) Then
.Cells(i, cSrcFirstCol).Resize(, cColumns).Copy _
rngTarget.Resize(, cColumns)
Set rngTarget = rngTarget.Offset(1, 0)
End If
Next
End With
sourceSheet.Parent.Close False
End Sub
You're going to want to add an If statement at the end. I havent tested this, but it should give you an idea of how to get this working.
'Your need to change this to what you need
Dim CustomerSheet = Customerworkbook.Worksheets("Sheet1")
If Customersheet.range("C11").value = targetSheet.range("A1").value then
targetSheet.Range("B14", "G500").Value = sourceSheet.Range("A2", "G500").Value
Else
Exit Sub
End If
I have to print multiple sheets in excel based on whether that sheet is relevant to a user or not. In a sheet called "Sheet2" I have in column A from cell 14, the sheet names. There are 24 sheets with different names in Column A. In each adjacent cell (in Column B), I have either True or False. I wish to print the sheets which have a True in column B. I am able to print to the sheets one by one and not all the relevant sheets simultaneously as one file. The code I use is as follows:
Sub CommandButton1_Click()
Dim wb As Workbook
Dim SheetsToPrint As String
Set wb = ThisWorkbook
Dim sheetWithData As Worksheet
Set sheetWithData = wb.Sheets("Sheet2")
Dim startNameRange, endNameRange As Integer
startNameRange = 14
endNameRange = 39
For i = startNameRange To endNameRange Step 1
Dim nameSheetToPrint As String
SheetsToPrint = sheetWithData.Range("A" & i).Value
Dim wsToPrint As Worksheet
Set wsToPrint = wb.Sheets(SheetsToPrint)
If sheetWithData.Cells(i, 2) = "True" Then
wsToPrint.PrintOut From:=1, To:=1
End If
Next i
End Sub
Adapt the vars and try this :
Sub PrintSheet()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim sheetWithData As Worksheet
Set sheetWithData = wb.Sheets("Sheet2")
'Add the first row number and the last row number where start the sheet name
Dim startNameRange, endNameRange As Integer
startNameRange = 2
endNameRange = 4
For i = 2 To 4 Step 1
Dim nameSheetToPrint As String
nameSheetToPrint = sheetWithData.Range("A" & i).Value
Dim wsToPrint As Worksheet
Set wsToPrint = wb.Sheets(nameSheetToPrint)
If sheetWithData.Cells(i, 2) = "True" Then
wsToPrint.PrintOut
End If
Next i
End Sub
I found code similar to the following where the data from one workbook is moved to another by using a loop. The code works except for the information that it moves is incorrect. Could someone tell me why it keeps copying the last column X number of times (where X = number of rows)? I want to copy the data between A2 and J11 only once instead of X rows of J2 and X rows of J3, and so on.
Sub CopySample()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lCol As Range, lRow As Range
Dim CurCell_1 As Range, CurCell_2 As Range
Application.ScreenUpdating = False
'~~> Change as applicable
Set wb1 = Workbooks("Sample1.xlsm")
Set wb2 = Workbooks("OverallData_Month_X.xlsm")
Set ws1 = wb1.Sheets("SampleSheet")
Set ws2 = wb2.Sheets("All Cylinders Data") '<~~ Change as required
For Each lCol In ws1.Range("A2:J11")
'~~> Why this?
Set CurCell_2 = ws2.Range("A2:J2")
For Each lRow In ws1.Range("A2:J11")
Set CurCell_1 = ws1.Cells(lRow.Row, lCol.Column)
If Not IsEmpty(CurCell_1) Then
CurCell_2.Value = CurCell_1.Value
Set CurCell_2 = CurCell_2.Offset(1)
End If
Next
Next
Application.ScreenUpdating = True
End Sub
Untested, but try changing this line Set CurCell_2 = ws2.Range("A2:J2") to :
Set CurCell_2 = ws2.Cells(1, lCol.Column)
UPDATE
Overall it seems that the above code is setting it's references to different sections of the workbook, and offsetting (moving) those references. I'd argue that there are more efficant ways to do this, and easier ways to code it as well. so while the above answer only solved half of the problems you were having, i've rewritten your code below so that it'll hopefully make more sence to you for you to understand + update.
I believe the below code example does what you're trying to accomplish:
(comments in code)
Sub CopySample
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Set wb1 = Workbooks("Sample1.xlsm")
Set wb2 = Workbooks("OverallData_Month_X.xlsm")
Set ws1 = wb1.Sheets("SampleSheet")
Set ws2 = wb2.Sheets("All Cylinders Data")
Dim rngCopyFromRange As Range
Set rngCopyFromRange = ws1.Range("A2:J11") '- name the copy range for ease of read
Dim rngPasteStartCell As Range
Set rngPasteStartCell = ws2.Range("A2") 'top left cellt o begin the paste
Dim lCurrentColumn As Long
Dim lCurrentRow As Long
For lCurrentColumn = 1 To rngCopyFromRange.Columns.Count 'for each column in the source data
For lCurrentRow = 1 To rngCopyFromRange.Rows.Count '-for each row in each column in source data
'set the offset of the starting cell's value equal ot the top left cell in the source data offset by the same amount
'- where the offsets are equal to the row/column we are on - 1
rngPasteStartCell.Offset(lCurrentRow - 1, lCurrentColumn - 1).Value = _
rngCopyFromRange.Cells(1, 1).Offset(lCurrentRow - 1, lCurrentColumn - 1).Value
Next lCurrentRow
Next lCurrentColumn
End Sub