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
Related
I have "Out of memory" issue with my Excel and VBA when I try to run macro below
Sub CopyPaste() ' macro to copy dynamic range
Dim lRow As Long
Dim sht As Worksheet
Set sht = Sheets("SQL")
sht.Activate
lRow = sht.Cells(sht.Rows.Count, 2).End(xlUp).Row
sht.Range("A1:Q" & lRow).Copy
Workbooks.Add
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("A:Q").EntireColumn.AutoFit
End Sub
My idea is to copy dynamic range from SQL tab in excel and paste to new workbook as values, columns to be autofit and all cells centered.
I have powerful machine at home, tried to reboot it and restart excel just in case.
Please, try the next adapted code. It does not activate, select anything. They are useless, only consuming Excel resources. Since you try copying only values, you also do not need using Clipboard:
Sub CopyPaste() ' macro to copy dynamic range
Dim lRow As Long, sht As Worksheet
Set sht = Sheets("SQL")
lRow = sht.cells(sht.rows.count, 2).End(xlUp).row 'last row on B:B column
Workbooks.Add
With sht.Range("A1:Q" & lRow)
ActiveSheet.Range("A1").Resize(.rows.count, .Columns.count).Value = .Value
End With
Columns("A:Q").EntireColumn.AutoFit
End Sub
If B:B is not the column you like to be the reference for the last used range cell, please change it using the necessary column number (instead of 2 in sht.cells(sht.rows.count, 2))
If you like using Clipboard, the next code will be suitable:
Sub CopyPaste() ' macro to copy dynamic range
Sheets("SQL").Copy 'it creates a new workbook with THAT single sheet
'in case of existing columns after Q:Q, use the next code to clear. If not, delete the next code lines:
Dim lastCol As Long
lastCol = ActiveSheet.cells(1, .ActiveSheet.Columns.count).End(xlToLeft).column
If lastCol > 17 Then
Range(cells(1, 18), cells(1, lastCol)).EntireColumn.Clear
End If
End Sub
If no any column after Q:Q, the code may have only a code line...
I am trying to loop through a range of cells and copy and paste the values of the ones that are not blank or do not contain an "X" (as well as the cell two to the right of it) to columns on another worksheet. I am hoping that the cells I paste them to will retain the pre-formatted conditional formatting set up prior to having stuff pasted to them. What I have so far is not working, and does not account for the cell two adjacent to the copy cell or just pasting the value without formatting. It would be great if then I could sort the first of the pairs of cells by alphabetically (also not accounted for). Thanks for any help!
Sub Wire_List_Export()
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Dim c As Range
Dim j As Integer
Set copySheet = Worksheets("LV Schedule")
Set pasteSheet = Worksheets("test")
For Each c In copySheet.Range("G274:G10000")
If Not c = "X" Or Not IsEmpty(c) Then
copySheet.Cells(c).Copy pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
End If
Next c
End Sub
Is this what you are looking for?
Sub Wire_List_Export()
'Declarations.
Dim RngCopyRange As Range
Dim IntOffsetCopy As Integer
Dim RngPasteRange As Range
Dim RngCell As Range
'Turning off screen updating.
Application.ScreenUpdating = False
'Setting variables.
Set RngCopyRange = Worksheets("LV Schedule").Range("G274:H10000")
Set RngPasteRange = Worksheets("test").Range("A1:B9727")
'Copying the range.
RngCopyRange.Copy
'Pasting the range (only values, skipping blank cells).
RngPasteRange.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=True, _
Transpose:=False
'Turning off cut-copy mode.
Application.CutCopyMode = False
'Turning on screen updating.
Application.ScreenUpdating = True
End Sub
I'm trying to write a macro to copy the contents of cell A1 of sheet wsVN to the first open cell in column F of sheet wsVL, then copy A2 to the next open cell in F, then A3 to the next and so on up to A305. Sheet VL has a header row with the first open cell being F2. That's where I'm trying to past A1. Then I have a couple rows with data then another open cell where I'd like to past A2. Then 5 rows of data before the next open cell where A3 should go. Here is as close as I have made it so far:
Sub Data_Transfer()
'
' Data_Transfer Macro
' Transfers VariableNames Data to the next available row of sheet VariableList.
Dim lastRow As Integer
Dim wsVN As Worksheet
Dim wsVL As Worksheet
Dim sourceRange As Range
Dim targetRange As Range
Set wsVN = Worksheets("VariableNames")
Set wsVL = Worksheets("VariationList")
If Len(wsVL.Range("F1").Value) > 0 Then
lastRow = wsVL.Range("F2").End(xlDown).Row
Else
lastRow = 2
End If
Set sourceRange = wsVN.Range("A1")
Set targetRange = wsVL.Range("F" & lastRow).Offset(1, 0)
sourceRange.Copy
targetRange.PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End Sub
Hopefully someone will offer some guidance on this. It would be appreciated very much!
Thanks
Try this, adjusting sheet names to suit.
Sub x()
Dim r As Range
With Worksheets("Sheet1") 'source sheet
For Each r In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
Worksheets("Sheet2").Range("F:F").SpecialCells(xlCellTypeBlanks)(1).Value = r.Value 'destination sheet
Next r
End With
End Sub
More on SpecialCells.
My formula is in M1.
I need to run a VBA that will copy that cell and paste it in Column G only but down 18 rows each time I run it and each time I run it, it starts in the next empty row in column G.
If I use record macro for doing it one time, this is what it looks like.
Selection.Copy
ActiveWindow.SmallScroll Down:=33
Range("G42:G59").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
I know this isn't the best way and I am not this advanced in Excel.
For anyone who needs help with this also, both Harassed Dad and jakrooster where great and i pieced together their answers to get it to work. Finish VBA i am using.
Sub Cash()
Dim rng_Copy As Range
Dim rng_Paste As Range
Set rng_Copy = Sheet1.Range("$M$1")
Set rng_Paste = Range("G" & ActiveSheet.Rows.Count).End(xlUp).Offset(1, 0)
rng_Copy.Copy
rng_Paste.Resize(18, 1).PasteSpecial xlPasteFormulas
End Sub
Sub Fred()
dim r as range
set r = range("G" & activesheet.rows.count).end(xlup).offset(1,0)
Range("M1").copy r
r.copy range(r.address & ":G" & r.row + 17)
end sub
Firstly I'd create a named range that returns the blank cell after the last filled cell in column G. So something like this:
=INDEX(Sheet1!$G:$G,MAX(2,IFERROR(MATCH(" *",Sheet1!$G:$G,-1),0),IFERROR(MATCH(1E+306,Sheet1!$G:$G,1),0))+1)
Then I'd use that named range in VBA to copy the formula in M1 and apply it to the next 18 rows.
Sub s_CopyPaste()
Dim rng_Copy As Range
Dim rng_Paste As Range
Set rng_Copy = Sheet1.Range("$M$1")
Set rng_Paste = Range("NAMED RANGE")
rng_Copy.Copy
rng_Paste.Resize(18, 1).PasteSpecial xlPasteFormulas 'resize the blank cell to an 18x1 range
End Sub
I have 80 or so columns of data. I need just 21 columns.
In my output, I would like the 21 columns to be in a particular order. For example, I want the value from the cell AX2 from my source file to go to A2, BW2 to go to B2, etc.
The source data may differ from month to month and could have as little as 1 row of data or hundreds so I would like this to loop until no data is left.
I got a run time error 424 object required. I have only outlined the rules for two columns but will work on the rest when I get the proper set up.
Sub Macro1()
'
' Macro1 Macro
'
'
Sheet4.Select
Application.ScreenUpdating = False
row_count = 2
Do While Sheet2.Range("A" & row_count) <> ""
Range("AX2:AX1000").Select
Selection.Copy
ActiveWindow.ActivateNext
Range("A").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveWindow.ActivateNext
Range("BW2:BW1000").Select
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.ActivateNext
Range("B").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
x = x + 1
ActiveWindow.ActivateNext
ActiveSheet.Next.Select
ActiveSheet.Next.Select
Loop
End Sub
I hope I didn't go too far. Try this subscript, it asks you to select a workbook, it will open the workbook, copy column B2 to last used Row on Column B, and paste it on the first workbook. Make sure to rename the CopyFromSheet and CopyToSheet on the code. Please read each line and try to understand what it is doing. Let me know if any questions.
Sub CopyPaste()
Dim openFile As FileDialog, wb As Workbook, sourceWb As Workbook
Dim CopyTo As String, CopyFrom As String
Dim lastRow As Long
Application.ScreenUpdating = False
Set wb = ThisWorkbook
Set openFile = Application.FileDialog(msoFileDialogFilePicker)
openFile.Title = "Select Source File"
openFile.Filters.Clear
openFile.Filters.Add "Excel Files Only", "*.xl*"
openFile.Filters.Add "All Files", "*.*"
openFile.Show
If openFile.SelectedItems.Count <> 0 Then
Set sourceWb = Workbooks.Open(openFile.SelectedItems(1), False, True, , , , True)
CopyFrom = "CopyFromSheetName"
CopyTo = "CopyToSheetName"
lastRow = sourceWb.Sheets(CopyFrom).Cells(Rows.Count, "B").End(Excel.xlUp).Row
sourceWb.Sheets(CopyFrom).Range("B2:B" & lastRow).Copy 'You can copy this Row and the Next and add as many as you want to copy the Columns Needed
wb.Sheets(CopyTo).Range("B1").PasteSpecial xlValues
Application.CutCopyMode = xlCopy
Else
MsgBox "A file was not selected"
End If
Application.ScreenUpdating = True
End Sub
I suggest you separate the copy logic from the setup of which columns to copy. That way it will be much easier to manage the setup.
In this code I have hard coded to Columns Pairs. Alternatively, you could put that data on a sheet and read it in.
Sub Demo()
'declare all your variables
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim rSource As Range
Dim rDest As Range
Dim CP() As Variant 'Column Pairs array
Dim idx As Long
'Set up an array of Source and Destination columns
ReDim CP(1 To 21, 1 To 2) 'Adjust size to suit number of column pairs
CP(1, 1) = "AX": CP(1, 2) = "A"
CP(2, 1) = "BW": CP(2, 2) = "B"
'and so on
' Source and Destination don't have to be in the same Workbook
' This code assumes the Source (and Destination) worksbooks are already open
' You can add code to open them if required
' If the data is in the same book as the code, use ThisWorkbook
' If the data is in a different book from the code,
' specify the book like Application.Workbooks("BookName.xlsx")
' or use ActiveWorkbook
'Update the names to your sheet names
Set wsSource = ThisWorkbook.Worksheets("SourceSheetName")
Set wsDest = ThisWorkbook.Worksheets("DestSheetName")
' Notice that form here on the code is independent of the Sheet and Column names
'Loop the column pairs array
For idx = 1 To UBound(CP, 1)
'if the entry is not blank
If CP(idx, 1) <> vbNullString Then
'Get reference to source column cell on row 2
Set rSource = wsSource.Columns(CP(idx, 1)).Cells(2, 1)
'If that cell is not empty
If Not IsEmpty(rSource) Then
'If the next cell is not empty
If Not IsEmpty(rSource.Offset(1, 0)) Then
'extend range down to first blank cell
Set rSource = wsSource.Range(rSource, rSource.End(xlDown))
End If
'Get a reference to the destination range, from row 2, same size as source
Set rDest = wsDest.Columns(CP(idx, 2)).Cells(2, 1).Resize(rSource.Rows.Count)
'Copy the values
rDest.Value = rSource.Value
End If
End If
Next
End Sub