I was looking for a VBA script to write data from a table to specified cell in a worksheet.
For eg: In the image table - column 1 is serial number, column 2 is data to be written, column 3 is sheet to which it should be written and column 4 is the cell in the corresponding sheet.
I am looking for a VBA script to write '1' from row 1 & column 2 to cell "A1" in sheet "A".
Here's code for it:
Sub Dump2Print()
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Dim rng As Range: Set rng = Application.Range("Dump!A1:A" & LastRow)
Dim i As Integer
Set wb = ActiveWorkbook
For i = 1 To rng.Rows.Count
MyValue = rng.Cells(RowIndex:=i, ColumnIndex:="B").Value
MySheet = rng.Cells(RowIndex:=i, ColumnIndex:="C").Value
MyRange = rng.Cells(RowIndex:=i, ColumnIndex:="D").Value
Set ws = wb.Sheets(MySheet)
ws.Activate
ws.Range(MyRange) = MyValue
Next
End Sub
This code will look at all the data in the table in sheet named "Dump" and read values from column "B","C" & "D".
Related
Sub Start()
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Sheets("1")
Set ws2 = Sheets("2")
Dim LastRow As Long, i As Long
LastRow = Cells(Rows.Count, "D").End(xlUp).row
For i = 1 To LastRow
ws1.Range("D" & i).copy
ws2.Range("A2").PasteSpecial Paste:=xlPasteFormats
Next i
If ws1.Range("A" & i) = vbNullString Then
Exit Sub
End If
End Sub
I'm trying to make it so this code pastes the interior fill from column D, Into Column A, unless there is already interior fill present.
Any input appreciated.
Edit: I'm trying to copy the format (interior fill) from Sheet 1 and Sheet 2's Column A's (until the last row) and paste it to Sheet Column A. I'm trying to copy over once cell at a time, and ignore if there is already fill present in sheet 3, because my I dont want the format from sheets 1 and 2 to overwrite eachtoher.
A pivot table has been created and I need a macro that can pick up the Pivot body data, with no filters, from a specified worksheet (Pivot1) and copy the results into another sheet (Selection) on the next blank cell.
I've used and modified the below, which I found on this site, however its not picking up my sheets and I get a runtime error '424'
Any ideas on how this can be executed?
Sub PastePivot()
Dim i As Long
Dim LR As Long
Dim j As Long
Dim c As Long
'Find last used row in Pivot1
LR = Pivot1.Cells(Pivot1.Rows.Count, 1).End(xlUp).Row
'Find last used row in Selection
j = Selection.Cells(Selection.Rows.Count, 1).End(xlUp).Row
'Loop through rows on Pivot1
For i = 3 To LR
'Decide whether to copy the row or not
If Pivot1.Cells(i, 1).Value <> "0" Then
'Update pointer to the next unused row in Selection
j = j + 1
'Only copy used columns, to stop it thinking every cell in the
'destination row is "used"
c = Pivot1.Cells(i, Pivot1.Columns.Count).End(xlToLeft).Column
'Copy the values (without using Copy/Paste via the clipboard)
Selection.Rows(j).Resize(1, c).Value = Pivot1.Rows(i).Resize(1, c).Value
End If
Next i
End Sub
If you want to get the body of a pivot table use it's DataBodyRange property.
The below code assumes you have 1 pivot table on 'Sheet1' and you want to copy it to 'Sheet2'.
Sub CopyPivotBody()
Dim ws As Worksheet
Dim pt As PivotTable
Dim rngBody As Range
Set ws = Sheets("Sheet1")
Set pt = ws.PivotTables(1)
Set rngBody = pt.DataBodyRange
rngBody.Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
End Sub
Note, if that doesn't give you the exact range you want you can offset/resize it like any other range.
I have Three worksheets, and essentially I want to select a cell in Column A of Sheet 2 (As the Active Cell) and check if there are any duplicates in Column A of Sheet 3 (The Range for this Sheet should be from A1 to the last row of Data).
If there are any duplicates, I would like a msgbox to display the number of duplicate values if it's greater than 3.
I have added comments explaining my logic in each step, please feel free to simplify my code as well:
Sub Check_Duplicates()
'Declaring variables
Dim Cell As Variant
Dim Source As Range
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
Dim rowAC As Long
Dim Counter As Long
'Assigning a worksheet to the decalred variables
Set sh1 = Sheet1
Set sh2 = Sheet2
Set sh3 = Sheet3
'Sets the Long variable as the Active Cell Row in Sheet 2
rowAC = ActiveCell.Row
'Initializing "Source" variable range to last row in Sheet 3
Set Source = sh3.Range("A1", sh3.Range("A1").End(xlDown))
'Looping through each cell in the "Source" variable Range
For Each Cell In Source
'Checking if the "Cell" values in Sheet 3 (in column A to the last row) are equal to the value in the Active Cell in Column A
If Cell.Value = sh2.Range("A" & rowAC).Value Then
'Checking whether the value in "Cell" already exists in the "Source" range
If Application.WorksheetFunction.CountIf(Source, Cell) > 1 Then
'Counts and stores the number of duplicate values from Sheet 3 "Cells" compared to the Active Cell value in Sheet 1 Column A
Counter = Application.WorksheetFunction.CountIf(sh3.Range("Source,Cell"), sh2.Range("A" & rowAC))
'If there are more than 3 duplicates then display a message box
If Counter > 3 Then
'Msgbox displaying the number of duplicate values in Sheet 3
MsgBox "No. of duplicates is:" & Counter
End If
End If
End If
Next
End Sub
Currently, my code gets to the first IF Statement and simply goes to the End IF, so it doesn't execute past this line and simply goes to Next and then End Sub:
If Cell.Value = sh2.Range("A" & rowAC) .Value Then
Cross Referencing:
https://www.mrexcel.com/board/threads/how-to-check-for-duplicates-and-display-a-count-msgbox.1125070/
Here is the final code I am using for anyone using this question as reference for their issues:
Sub Check_Duplicates()
'Declaring variables
Dim Source As Range
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
Dim rowAC As Long, Counter As Long
'Assigning a worksheet to the decalred variables
Set sh1 = Sheet1
Set sh2 = Sheet2
Set sh3 = Sheet3
'Sets the Long variable as the Active Cell Row in Sheet 2
rowAC = ActiveCell.Row
'Initializing "Source" variable range to last row in Sheet 3
Set Source = sh3.Range("A1", sh3.Range("A" & Rows.Count).End(xlUp))
'count number of times is in Source range
Counter = Application.WorksheetFunction.CountIf(Source, sh2.Range("A" & rowAC))
'If there are more than 3 duplicates then display a message box
If Counter > 3 Then
'Msgbox displaying the number of duplicate values in Sheet 3
MsgBox "No. of duplicates is: " & Counter
End If
End Sub
I have two questions
How to combine data using two of the cells from workbookA and copy to workbookB on the same cell?
How do I start using for loop to copy it until the last row/column?
I have no clue on how to combine the data and I do not know where to place the variable inside the code for it to loop until its last column.
Dim Tlastrow As Integer
Tlastrow = Cells(1, Columns.Count).End(xlToLeft).Column
For r = 1 To Tlastrow
Workbooks("InputB.xls").Worksheets("HC_MODULAR_BOARD_20180112").Range("F3:G3").Copy _
Workbooks("Output.xls").Worksheets("Sheet1").Range("I3")
Next
Try this:
Option Explicit
Sub Paste()
Dim wsInput As Worksheet, wsOutput As Worksheet, LastRow As Long, C As Range
Set wsInput = Workbooks("InputB.xls").Worksheets("HC_MODULAR_BOARD_20180112")
Set wsOutput = Workbooks("Output.xls").Worksheets("Sheet1")
With wsInput
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row 'Last Row with data
For Each C In .Range("F3:F" & LastRow) 'loop for every row with data
wsOutput.Cells(C.Row, "I").Value = C & " " & C.Offset(0, 1)
Next C
End With
End Sub
This code is assuming you want to paste every row from your input workbook to the output workbook on the same rows, but merging F and G columns. It's just pasting the values, not formulas or formats.
My destination workbook (wb1) is a table with a range of A1:Q740 and has a header row, the data workbook (wb2) that I want to copy from always has the same columns A:Q with the number of rows varying.
In both workbooks, the data in columns A:F for most, but not all rows is identical. I would like to compare those columns in both worksheets, and if a given row in A:F matches the other workbook, copy the data from that row for columns G:Q from the data workbook to the row with matching data in the destination workbook.
My issue is most of the time the rows between the two workbooks don't line up. For example, in both workbooks cells A2:F2 match. However, the farther down the workbook you go the rows diverge. In the data workbook, cells A153:F153 are the same as the destination workbook cells A159:F159. So, in this example I would like my code to copy data from cells G2:Q2 and G153:Q153 and paste them to the destination workbook in cells G2:Q2 and G159:Q159, respectively.
I've got my workbooks, worksheets and ranges named, but I'm not sure how best to run the comparison or how to code the copy/paste destination correctly.
EDIT: Updated code as below, it works until row 34 and then breaks since the matching data is no longer in the same row number in each workbook.
Option Explicit
Sub MergeWorksheets()
Dim wb1 As Workbook '2017 Tracking Report
Dim wb2 As Workbook 'Book# Drake Export from CSM
Dim Drake17 As Worksheet
Dim ImportDataFull As Range 'Full Range of Drake17 Export, less header row
Dim lastRow As Long 'Last Row of Drake17 Worksheet
Dim lastRow2 As Long 'Last Row of Drake Export
Dim ImportData As Range 'Drake Export Data
Dim DesImportData As Range 'Destination Range of Data for Compare
Dim DesImportRange As Range 'Destination for ImportRange
Set wb1 = Workbooks("2017 Tracking Report.xlsm")
Set wb2 = Workbooks(Workbooks.Count) 'Sets the most recently opened WB
Set Drake17 = wb1.Sheets("Drake17")
lastRow = Drake17.Range("A" & Rows.Count).End(xlUp).Row
Set DesImportData = Drake17.Range("A1:F" & lastRow)
Set DesImportRange = Drake17.Range("G1:Q" & lastRow)
wb2.Activate
lastRow2 = Range("A" & Rows.Count).End(xlUp).Row
Set ImportDataFull = Range("A1:Q" & lastRow2) 'Full Data Export Less Header Row
Set ImportData = Range("A1:F" & lastRow2) 'Sets range of data to compare
Dim r As Range
Dim i As Integer
With Columns(6)
.NumberFormat = "m/d/yyy"
.Value = .Value
End With
With Columns(2)
.NumberFormat = "General"
.Value = .Value
End With
Application.ScreenUpdating = False
For i = 2 To lastRow2
With ImportDataFull
Set r = Range("G" & i, "Q" & i)
If ImportData.Cells(i, 1) = DesImportData.Cells(i, 1) And _
ImportData.Cells(i, 2) = DesImportData.Cells(i, 2) And _
ImportData.Cells(i, 3) = DesImportData.Cells(i, 3) And _
ImportData.Cells(i, 4) = DesImportData.Cells(i, 4) And _
ImportData.Cells(i, 5) = DesImportData.Cells(i, 5) And _
ImportData.Cells(i, 6) = DesImportData.Cells(i, 6) Then
r.Copy DesImportRange.Rows(i)
r.EntireRow.HorizontalAlignment = xlCenter
End If
End With
Next i
Application.ScreenUpdating = True
End Sub