Private Sub CommandButton1_Click()
Dim rCell As Range
Dim i As Long
Dim rNext As Range
'loop through the cells in column A of the source sheet
For Each rCell In Sheet1.Range("A3:U25")
'loop as many times as the value in column U of the source sheet
For i = 1 To rCell.Offset(0, 22).Value
'find the next empty cell to write to in the dest sheet
Set rNext = Sheet2.Cells(Sheet2.Rows.Count, 1).End(xlUp).Offset(1, 0)
'copy A and B from source to the dest sheet
rCell.Resize(1, 22).Copy rNext.Resize(1, 1)
Next i
Next rCell
End Sub
Ok this works great except how do I copy the values not formulas of cells in sheet1 to sheet2? Like a date transfers as 1/0/1900, when it needs to be 5/5/2011
You need to use the PasteSpecial method with the xlPasteValues as the PasteType. Something like:
Sheet2.Cells(1,1).PasteSpecial xlPasteType.xlPasteValues
Private Sub CommandButton1_Click()
Dim rCell As Range
Dim i As Long
Dim rNext As Range
'loop through the cells in column A of the source sheet
For Each rCell In Sheet4.Range("A3:U25")
'loop as many times as the value in column U of the source sheet
For i = 1 To rCell.Offset(0, 23).Value
'find the next empty cell to write to in the dest sheet
Set rNext = Sheet12.Cells(Sheet12.Rows.Count, 1).End(xlUp).Offset(1, 0)
'copy A and B from source to the dest sheet
rCell.Resize(1, 23).Copy
rNext.Resize(1, 1).PasteSpecial (xlPasteValues)
Next i
Next rCell
End Sub
Now I'm getting a runtime-13 type mismatch on below part of the code. When it errors, click end and it works fine. Don't want to have to click end.
For i = 1 To rCell.Offset(0, 23).Value
Related
Hi I am new to VBA and have hit a wall. Tried piecing together snippets of code with the little I understand but think I am over my head. I would greatly appreciate any help constructing a block of code to achieve the following goal:
In the following worksheet
I am trying to loop through column A and identify any blank cells.
If the cells are blank I would like to copy the values in the range of 4 cells adjacent to the right of the blank cell in column A. For example: if loop identified A2 as blank cell then the loop would copy the values in range("B2:E2")
From here I would like to paste the values below the copied range to only the rows that are not blank in column A. For example: The loop would identify not blank rows in column A as ("A3:A9") and paste data below the copied range to range ("B3:E9")
The loop would stop at the next blank row in column and restart the process
Here is a screen shot of the data:
Here is what I have so far, sorry its not much Thanks in advance!
Sub select_blank()
For Each Cell In Range(ActiveCell, ActiveCell.End(xlDown))
If IsEmpty(ActiveCell.Value) = True Then
ActiveCell.Offset(, 1).Resize(, 5).copy
End If
Next
End Sub
Your code only needs a few tweaks (plus the PasteSpecial!) to get it to work:
Sub select_blank()
Dim cel As Range
With ActiveSheet
'specify that the range to be processed is from row 2 to the
'last used cell in column A
For Each cel In .Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp))
If IsEmpty(cel.Value) Then
'If the cell is empty, copy columns B:F
cel.Offset(, 1).Resize(, 5).Copy
Else
'If the cell is not empty, paste the values previously copied
'NOTE: This relies on cell A2 being empty!!
cel.Offset(, 1).PasteSpecial
End If
Next
End With
Application.CutCopyMode = False
End Sub
I cannot make much sense of what you want, it seems to contradict itself. But, since I highly doubt anyone else is going to help you with this (per the rules), I'll give you a much better start.
Sub Test()
Dim nRow As Integer
nRow = 1
Do Until Range("A" & nRow) = "" And Range("A" & nRow + 1) = ""
If Range("A" & nRow) = "" Then
' do stuff here in the loop
End If
nRow = nRow + 1
Loop
End Sub
Sub copyRange()
Dim rngDB As Range, vDB, rng As Range
Set rngDB = Range("a2", Range("a" & Rows.Count).End(xlUp))
For Each rng In rngDB
If rng = "" Then
vDB = rng.Offset(, 1).Resize(1, 4)
Else
rng.Offset(, 1).Resize(1, 4) = vDB
End If
Next rng
End Sub
I'd like to copy data from 'Sheet1' in a specific cell to the next available empty cell in 'Sheet2' such that changes (F9) result in data being copied from Sheet1 and a columne of data being populated in Sheet2.
So far I have the below, which throws an error around: (.Rows.Count
Is it possible to popluate a column in Sheet2 every time the workbook is refreshed on 'F9'?
'In this example I am Copying the Data from Sheet1 (Source) to Sheet2 (Destination)
Private Sub worksheet_calculate()
'Method 2
'Copy the data
Sheets("Sheet1").Range("I1").Copy
'Activate the destination worksheet
Sheets("Sheet2").Activate
'Select the target range
Sheet2.Cells(.Rows.Count, "A").End(xlUp).Row
'Paste in the target destination
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub
You chose last used row incorrectly. Try this:
Private Sub worksheet_calculate()
Dim lstrow As Integer
'Method 2
'Copy the data
Sheets(1).Range("I1").Copy
'Activate the destination worksheet
Sheets(2).Activate
'Select the target range
lstrow = Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row
'Paste in the target destination
ActiveSheet.Cells(lstrow + 1, 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub
Should you be interested in pasting values only
Private Sub worksheet_calculate()
With Worksheets("Sheet2")
.Cells(.Rows.Count, "A").End(xlUp).Offset(1).Value = Worksheets("Sheet1").Range("I1").Value
End With
End Sub
Try the code below, it will copy Cell I1 from "Sheet1" to next available row in Column A in "Sheet 2".
It's better if you avoid using Activate and ActiveSheet, instead you can just Copy>Paste in one line (as in the code below)
Not sure why you want this code in the worksheet_calculate event.
'In this example I am Copying the Data from Sheet1 (Source) to Sheet2 (Destination)
Private Sub worksheet_calculate()
Dim LastRow As Long
With Sheets("Sheet2")
' find last row in Sheet 2
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'Copy the data and Paste in Sheet 2 (+1 for next avaialble row)
Sheets("Sheet1").Range("I1").Copy Sheets("Sheet2").Range("A" & LastRow + 1)
Application.CutCopyMode = False
End Sub
Edit 1:
Modifed code according to PO updated information:
In order to avoid the F9 infinite loop, use the Application.EnableEvents = False inside your Sub.
Private Sub worksheet_calculate()
'In this example I am Copying the Data from Sheet1 (Source) to Sheet2 (Destination)
Dim LastRow As Long
Application.EnableEvents = False
With Sheets("Sheet2")
' find last row in Sheet 2
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
' copy the values only from "Sheet1" to "Sheet2"
.Range("A" & LastRow + 1).Value = Sheets("Sheet1").Range("I1").Value
End With
Application.CutCopyMode = False
Application.EnableEvents = True
End Sub
You can do the Copy>Paste in one line like #user3598756 wrote:
With Worksheets("Sheet2")
.Cells(.Rows.Count, "A").End(xlUp).Offset(1).Value = Worksheets("Sheet1").Range("I1").Value
End With
I am new in VBA and want copy rows of the following worksheet based on the value of column OFFICE:
So if you notice that there are 10 rows having 4 types of office: Office-A, Office-B, Office-C, Office-D (and so on,it could be more office types ).So i want a VBA code that dynamically creates as many new sheets based on number of types of office in OFFICE column and move the rows that matched with a corresponding office type into new sheet.For: here it will look at column OFFICE and create 4 new sheets, because there 4 types of data and move corresponding rows to these sheets.Please help me to do that.Thanks
try this:
Option Explicit
Sub main()
Dim cell As Range, dataRng As Range
With Worksheets("Offices").UsedRange '<--| change "Offices" with your actual sheet name
Set dataRng = .Cells
With .Offset(, .Columns.Count).Resize(, 1)
.Value = .Parent.Columns("B").Value
.RemoveDuplicates Columns:=Array(1), Header:=xlYes
With .SpecialCells(XlCellType.xlCellTypeConstants)
For Each cell In .Offset(1).Resize(.Rows.Count - 1)
AddSheet cell.Value
With dataRng
.AutoFilter field:=2, Criteria1:=cell.Value
.SpecialCells(xlCellTypeVisible).Copy Destination:=Worksheets(cell.Value).Cells(1, 1)
End With
Next cell
End With
.Parent.AutoFilterMode = False
.Clear
End With
End With
End Sub
Sub AddSheet(shtName As String)
Dim ws As Worksheet
On Error Resume Next
Set ws = Worksheets(shtName)
On Error GoTo 0
If ws Is Nothing Then Worksheets.Add.Name = shtName
End Sub
This will create a new sheet for unique data in column B and rename the sheet to the cell value. You may have to adapt the code to suit your purpose.
Sub dave()
Dim dicKey, dicValues, data, lastrow As Long
Dim i As Long, ws As Worksheet, wsDest As Worksheet
Set ws = ActiveSheet
lastrow = Cells(Rows.count, 2).End(xlUp).Row
data = Range("B2:B" & lastrow) ' load data into variable
With CreateObject("scripting.dictionary")
For i = 1 To UBound(data)
If .Exists(data(i, 1)) = False Then
dicKey = data(i, 1) 'set the key
dicValues = data(i, 1) 'set the value for data to be stored
.Add dicKey, dicValues
Set wsDest = Sheets.Add(After:=Sheets(Worksheets.count))
wsDest.Name = data(i, 1)
Sheets(data(i, 1)).Cells(1, 1).Value = ws.Cells(i + 1, 2).Value
End If
Next i
End With
End Sub
I want to create a logical range based on the location of where the program finds the string.
sample Workbook
What I am attempting:
This sample workbook will have a column of dates and a column of statuses per sheet. Each sheet will also have another column to the right of the "status" column that simply outputs the word "Current" for that date. (If this is redundant and you would rather search for the current date in that first column that shows all the dates, feel free to ignore this. I only put it in to make it simple for me.)
This program needs to search in the column to the right of the status column for the string "current" and copy and paste that "status" cells value adjacent to it (or just locate the address via the rows date and run the sub for that specific row's "Status" cell if you wanted to ignore the "current" string thing). The Sample will not have the actual formulas in the status cells and only the values I put in for reference but it is the same principle.
Sub Ruby()
If Sheets("ALPHA").Range("T2:T5000").Value = "Current" Then
Sheets("ALPHA").Select
Call copy
End If
If Sheets("BRAVO").Range("T2:T5000").Value = "Current" Then
Sheets("BRAVO").Select
Call copy
End If
If Sheets("CHARLIE").Range("T2:T5000").Value = "Current" Then
Sheets("CHARLIE").Select
Call copy
End If
End Sub
Sub copy()
'
' copy Macro
'
'
Range("S98").Select
Selection.copy
Range("S98").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
From what your code looks like, you want to change the formula in Column S to a value.
You can loop through each sheet and make it happen
Sub RubyLoop()
Dim sh As Worksheet, LstRw As Long
Dim rng As Range, c As Range
For Each sh In Sheets
With sh
LstRw = .Cells(.Rows.Count, "T").End(xlUp).Row
Set rng = .Range("T2:T" & LstRw)
For Each c In rng.Cells
If c = "Current" Then c.Offset(, -1).Value = c.Offset(, -1).Value
Next c
End With
Next sh
End Sub
With end if
Sub RubyLoop2()
Dim sh As Worksheet, LstRw As Long
Dim rng As Range, c As Range
For Each sh In Sheets
With sh
LstRw = .Cells(.Rows.Count, "T").End(xlUp).Row
Set rng = .Range("T2:T" & LstRw)
For Each c In rng.Cells
If c = "Current" Then
c.Offset(, -1).Value = c.Offset(, -1).Value
End If
Next c
End With
Next sh
End Sub
I have a combo box with a value that I would like to be searched for in another workbook column. The code using autofilter then returns the rows which have that value in the same column(column 4).
It works correctly however the first row of the source is always being copied over to the destination, weather it does or doesn't not have the value being looking for in the specific column.
The offset or cell shifting is being used as the first two row in both sheets are headers
Sub CommandButton1_Click()
'Look in data repository for the Combobox filter value and only return those associated rows (can be more than one)
Dim DataBlock As Range, Dest As Range
Dim LastRow As Long, LastCol As Long
Dim SheetOne As Worksheet, SheetTwo As Worksheet
Dim PN As String
PN = ComboBox1.Value
'set references up-front
Set SheetTwo = ThisWorkbook.Worksheets("Report") 'this is the expiditing report
Set SheetOne = Workbooks.Open("C:\Users\Colin\Documents\Nexen\Data Repository V1.xlsm").Sheets("Data") 'this is the expiditing report
Set Dest = SheetTwo.Cells(3, 1) '<~ this is where we'll put the filtered data
'identify the "data block" range, which is where
'the rectangle of information that Ill apply
'.autofilter to
With SheetOne
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
LastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
Set DataBlock = .Range(.Cells(3, 1), .Cells(LastRow, LastCol))
'Set DataBlock = Range("A3:AV65000") 'for testing
End With
'apply the autofilter to column D (i.e. column 4)
With DataBlock
'can use offset .Offset(2, 0).
.AutoFilter Field:=4, Criteria1:=PN
'copy the still-visible cells to sheet 2
.SpecialCells(xlCellTypeVisible).Copy Destination:=Dest
End With
'turn off the autofilter
With SheetOne
.AutoFilterMode = False
If .FilterMode = True Then .ShowAllData
End With
End Sub
Sub CommandButton2_Click()
Dim MyBook As String
Dim MyRange As Range
'Get name of current wb
MyBook = ThisWorkbook.Name
Set MyRange = MyBook.Sheets("Report").Range("T3,AC65000")
'ActiveWorkbook.Close savechanges:=True
MyBook.Activate
End Sub
![etr][1]
So why am i getting the first row back regardless? I have tried a multitude of things.
Your .Range needs to be in a Table with a header for AutoFilter to work properly.