Objective: I'm trying to copy, find and paste data as per the find (that is Region).
Problem: I'm getting the desired output when I'm defining where to paste the data. But this is not what the macro is suppose to do. It's suppose to look for that Region name and then paste the data under the appropriate title and so on.
Here is what I've written so far:
Sub DataPasting()
ApplicationUpdating = False
Sheets("Sheet1").Range("I2:J2").Copy 'copy and pasting the data set from Sheet1
Sheets("Stories & Topics").Select
Dim RegionColumn As Long
Dim erow As String
RegionColumn = Application.WorksheetFunction.Match(Sheets("Raw").Range("H1"), Sheets("Stories & Topics").Range("A1:Z1"), False)
erow = ThisWorkbook.Worksheets("Stories & Topics").Cells(Rows.Count, "B").End(xlUp).Row
ThisWorkbook.Worksheets("Stories & Topics").Paste (ThisWorkbook.Worksheets("Stories & Topics").Range("B" & erow + 1))
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ApplicationUpdating = True
End Sub
Note:
Sheet1 = Sheet from where the data is to be copied
Stories & Topics = Destination sheet where the data has to be pasted
I also tried Vlookup and Match but no use.
Thanks!
It's difficult to tell from your code exactly what you're doing but something like this should work:
Sub DataPasting()
Dim RegionColumn 'variant
Dim erow As Long
Dim shtRaw As Worksheet, shtSaT As Worksheet, shtOne As Worksheet
Set shtRaw = ThisWorkbook.Sheets("Raw")
Set shtSaT = ThisWorkbook.Sheets("Stories & Topics")
Set shtOne = ThisWorkbook.Sheets("Sheet1")
ApplicationUpdating = False
RegionColumn = Application.Match(shtRaw.Range("H1").Value, _
shtSaT.Range("A1:Z1"), 0)
If Not IsError(RegionColumn) Then
erow = shtSaT.Cells(Rows.Count, "B").End(xlUp).Row
shtSaT.Cells(erow, RegionColumn).Resize(1, 2).Value = shtOne.Range("I2:J2").Value
End If
ApplicationUpdating = True
End Sub
Related
I have 135 rows of data in columns A to U
I am trying to write a script that will help me copy each column of data one under another to a clean worksheet.
Right now i wrote some code that will do it for the first two columns and i would prefer to have it done more automatically/dynamically instead of me copy pasting these two code blocks and altering the ranges
Range("A764:A897").Select
Selection.Copy
Sheets("New").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Sheets("Rom").Select
Range("B764:B897").Select 'id like to have this increment automaticaly
Selection.Copy
Sheets("New").Select
Range("A135").Select 'id like to have this increment automaticaly
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Try this. Adjust sheet name as necessary.
You can speed up the operation by directly transferring values rather then copying and pasting.
You could define the 134 as a constant so you only have to change once in the code rather than three times.
Sub x()
Dim rCopy As Range
Dim r As Long: r = 1
Set rCopy = Sheets("Name of source sheet").Range("A764").Resize(134) 'adjust sheet name
Do Until IsEmpty(rCopy(1))
Sheets("New").Cells(r, 1).Resize(134).Value = rCopy.Value
Set rCopy = rCopy.Offset(, 1)
r = r + 134
Loop
End Sub
Supposing your data in sheet “Rom” start at row 764:
Sub test()
Dim ws1, ws2 as string
Dim i, lr, lc as long
ws1 = “Rom”
ws2 = “New”
lc = sheets(ws1).cells(764,columns.count).end(xltoleft).column
For i = 1 to lc
lr = sheets(ws2).cells(Rows.count,1).End(xlUp).row + 1
sheets(ws1).range(cells(i, 764),cells(i,897)).Select
Selection.Copy
Sheets(ws2).cells(lr,1).Select
Selection.PasteSpecial Paste:=xlPasteValues
Next
End sub
You can read in each column of data to an array and then paste it into your new column. In this way, you can perform any mutations needed on the data.
If you have 135 rows (always)
Dim ws As Worksheet, arr As Variant, myRange As Range, i As Integer, col As Integer, k As Integer
Set ws = ThisWorkbook.Sheets("Sheet1") ' or whatever your worksheet is
ReDim arr(1 To 135*22) ' 22 letters from A To U
k = 1
With ws
For col = 1 To 22
For i = 764 To 897
arr(k) = .Cells(col, i).Value2 ' if you need to do anything else here
k = k+1
Next i
Next col
End with
Set ws = ThisWorkbook.Sheets("New") 'or wherever this is going
With ws
.Range("A1").Resize(UBound(arr), 1).Value = Application.Transpose(arr)
End with
I have merged cells across a certain range. The number of merged areas varies by worksheet, some have 2, some have 10. Once the new file is created and saved, all merged areas pull the text back into the first cell in the range. I am really trying to save an exact hard coded copy, with a different file name.
Here is the portion of code that is used to save values and then SaveCopyAs:
Sheets("Send").Visible = True
Sheets.Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Paste
Application.CutCopyMode = False
Dim thisWb As Workbook, d As Integer
Set thisWb = ActiveWorkbook
d = InStrRev(thisWb.FullName, ".")
'ActiveWorkbook.SaveAs Filename:=Left(thisWb.FullName, d - 1) & "-Prelims" & Mid(thisWb.FullName, d)
Sheets("Send").Visible = False
Dim newFileName As String
newFileName = Left(thisWb.FullName, d - 1) & "-Prelims" & Mid(thisWb.FullName, d)
thisWb.SaveCopyAs Filename:=newFileName
This seems like it should be easy but I haven't been able to find the answer here on SO or anywhere else.
Here is what your code should look like. This should be far more efficient for you
Let me know if anything is wrong:
Sub test()
Dim thisWb As Workbook, ws As Worksheet, d As Integer, lastRow As Long
Set ws = Sheets("Send")
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row 'Finds the bottom populated row
With ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, 1)) 'This find the bottom of column A
.Value = .Value 'Change to text rather than formula
End With
Set thisWb = ActiveWorkbook
d = InStrRev(thisWb.FullName, ".")
Sheets("Send").Visible = False
Dim newFileName As String
newFileName = Left(thisWb.FullName, d - 1) & "-Prelims" & Mid(thisWb.FullName, d)
thisWb.SaveCopyAs Filename:=newFileName
End Sub
Here is how my code currently works:
On sheet 1 at location B5, the value of the cell is Dog. On sheet 2, C15, the paste location, the value is also Dog.
What I would like is for C15 to be =$B$5. This way, I can change B5 on just sheet 1 and C15 on sheet 2 changes as well.
I thought I could use a paste special but can't find any that would work since it's not really a paste function.
I thought I could maybe use this:
Sheets("Projects").Range(LastRow, "B").Value =_
Sheets("Database").Range(Newproject - Masterrow + 1, "C").Value
But it did not work, and so I'm here...
Current code:
Code:
Sub FindProjectName()
Dim LastRow As Long
Dim Newproject As Long
Dim MasterTemplate As Range
Dim Masterrow As Long
'MasterTemplate is the database entry template.
Masterrow = Worksheets("Database").Range("MasterTemplate").Rows.Count
LastRow = Sheets("Projects").Cells(Rows.Count, "B").End(xlUp).Row
Newproject = Sheets("Database").Cells(Rows.Count, "C").End(xlUp).Row
Sheets("Projects").Cells(LastRow, "B").Copy Sheets("Database").Cells(Newproject - Masterrow + 1, "C")
With Sheets("Database")
.Range("DBASE").Rows(1).Copy
.Range("DBASE").Rows(Newproject - Masterrow).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
End Sub
I can't just use =SheetName!B5 for example because the template is copied to a new location everytime the code runs. I tried that.
The code below will accomplish what you described in the first part of your question. Once you understand how it works, I think you'll be able to apply it to your situation. If not, feel free to ask questions.
Sub formulaTest()
Dim sh1 As Worksheet, r1 As Range, r2 As Range
Set sh1 = Worksheets("Sheet1")
Set r1 = sh1.Range("B5")
r1 = "Dog"
Set r2 = Worksheets("Sheet2").Range("C15")
r2.formula = "=" & sh1.Name & "!" & r1.Address
End Sub
Here's the code you supplied in a followup comment along with an animated gif showing it working (except for overwriting the last item, "6")
Sub formulaTester()
Dim Feeder As Worksheet
Dim OneCell As Range
Dim TwoCell As Range
Set Feeder = Sheets("Projects")
Set OneCell = Feeder.Range("B" & Rows.Count).End(xlUp)
OneCell = "Cow"
Set TwoCell = Sheets("Tester2").Range("C17")
TwoCell.formula = "=" & Feeder.Name & "!" & OneCell.Address
End Sub
i am a novice when it comes to VBA and would like some help.
I am trying to copy one cell at a time from one sheet to to another. The reason for this is because I want to copy one cell (account #) from a list (sheet "List") and paste into a predefined cell is another sheet ("Analysis") and run code that will extract data from a program. i want to then repeat this process for all the account #s in that list until the list ends. The # of accounts in this list will change periodically. Account # will always be entered into Cell "F2"
The code i am using to extract data is,
Range("F2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.Run "'Option holding.xls'!SecurityDistribution"
Loop through the list and call the macro
Sub Do_It()
Dim Sh As Worksheet, ws As Worksheet
Dim Rng As Range, LstRw As Long
Dim F1 As Range, c As Range
Set Sh = Sheets("Transaction Analysis")
Set F1 = Sh.Range("F1")
Set ws = Sheets("List")
With ws
LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
Set Rng = .Range("A2:A" & LstRw)
For Each c In Rng.Cells
F1.Value = c
MsgBox "Call Macro Here"
Next c
End With
End Sub
I'm using this code to paste values for a range but I started facing issues whenever my data is in a million or more line numbers, I wanted to break the range and run the same code in 4/5 parts (loops), can some one help me with it
Range("F14:J14").Select
Selection.Copy
With ActiveSheet
RowCount = .Cells(.Rows.Count, "B").End(xlUp).Row
End With
Range("F14:J14").Select
Selection.Copy
Range("f15:J" & RowCount).Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("f15:J" & RowCount).Select
Selection.Copy
Range("f15:J" & RowCount).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
You are right, copying very large number of cells is problematic, so processing the data in blocks is a good idea.
That said, relying on Select and Copy PasteSpecial is also problematic.
I would suggest this alternative
Sub Demo()
Dim rSrc As Range
Dim rDst As Range
Dim rBlk As Range
Dim RowCount As Long
Dim CopyRowStart As Long
Dim CopyRowNum As Long
' Set number of rows to process at a time
CopyRowNum = 100000
' Set references to source and Destination ranges
With ActiveSheet
Set rSrc = .Range("F14:J14")
RowCount = .Cells(.Rows.Count, "B").End(xlUp).Row
Set rDst = .Range("F15:J" & RowCount)
End With
' Copy data in blocks
CopyRowStart = 0
Set rBlk = rDst.Resize(CopyRowNum)
Do While CopyRowStart + CopyRowNum <= rDst.Rows.Count
' Copy formulas
rBlk.Formula = rSrc.Formula
' Convert to values
rBlk.Value = rBlk.Value
' Move to next block
If rBlk.Row + CopyRowNum + CopyRowStart - 1 > rDst.Row + rDst.Rows.Count - 1 Then
Exit Do
End If
Set rBlk = rBlk.Offset(CopyRowNum, 0)
CopyRowStart = CopyRowStart + CopyRowNum
DoEvents
Loop
' Copy remaining rows
If rBlk.Row + CopyRowNum <= rDst.Row + rDst.Rows.Count - 1 Then
Set rBlk = rBlk.Resize(rDst.Row + rDst.Rows.Count - rBlk.Row - CopyRowNum)
Set rBlk = rBlk.Offset(CopyRowNum, 0)
rBlk.Formula = rSrc.Formula
rBlk.Value = rBlk.Value
End If
End Sub
Note, the rather convoluted range size calculation are designed to avoid exceeding the size of the sheet, when the number of rows nears the end of the sheet (1,048,576 rows)