Hi alI am trying to copy data from a series of workbooks into a master file. The master file contains the spreadsheet names, and sheet names to loop through as strings and I have that process working fine. But now I need to match the names in column A and row 1 with the data in each worksheet and copy the cell including any comments. I had the vlookup working but it does not copy the comments. So I have tried to do a couple of match statements to find the cell column and row numbers but cannot seem to get it to work. Any ideas??
Sub GroupTwo()
Dim path As String
Dim i As Integer
Dim Dsheet As String
Dim wb As Workbook
Dim upi
Dim cmt As Comment
Dim iRow As Integer
Dim col As Integer
Dim lookrange As Range
Dim G2 As Worksheet
Dim colRange As Variant
Dim rowRange As Range
Dim rowCell As Variant
Dim colCell As Variant
Set lookrange = ThisWorkbook.Sheets("Lookups").Range(ThisWorkbook.Sheets("Lookups").Cells(3, 1), ThisWorkbook.Sheets("Lookups").Cells(11, 2))
Set G2 = ThisWorkbook.Sheets("Group_two")
Application.DisplayAlerts = False
upi = 2
coln = 2
For i = 60 To 61
path = ThisWorkbook.Sheets("Sheet7").Cells(1, i).Value
Dsheet = ThisWorkbook.Sheets("Sheet7").Cells(2, i).Value
Set wb = Workbooks.Open(path)
Set colRange = wb.Sheets(Dsheet).Range(wb.Sheets(Dsheet).Cells(4, 2), wb.Sheets(Dsheet).Cells(4, 56))
Set rowRange = wb.Sheets(Dsheet).Range(wb.Sheets(Dsheet).Cells(7, 1), wb.Sheets(Dsheet).Cells(27, 1))
For c = 2 To 57
For r = 8 To 73
Set rowCell = Application.Match(G2.Cells(r, 1), rowRange, 0)
Set colCell = Application.Match(G2.Cells(4, c), colRange, 0)
wb.Sheets(Dsheet).Range(rowCell, colCell).Copy
G2.Cells(r, c).PasteSpecial Paste:=xlPasteComments, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Next r
Next c
do some stuff with the comment
wb.Close SaveChanges:=False
Next i
Have you considered copying everything over at the same time?
So instead of this:
G2.Cells(r, c).Value = wb.Sheets(Dsheet).Range(rowCell, ColCell, colRange, 0)).copy
Maybe you could do this:
wb.Sheets(Dsheet).Range(rowCell, ColCell, colRange, 0)).copy
G2.Cells(r, c).PasteSpecial Paste:=xlPasteComments, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
See this link for more information on the PasteSpecial method.
See this link for more information on the different paste types.
Related
Hi guys i need some help on VBA.
I have range of numbers in sheet 1 from cells A6:O29. Next I have specific numbers selected in Sheet 3 in Column "B".
[![enter image description here][1]][1]
[![enter image description here][2]][2]
I want to loop throw each value in Sheet 3 Column B and find that specific value in Sheet 1 range A6:O29
Next it should paste Entire Row from Sheet 1 starting From Column (Q:CF) in Sheet 3 Starting from Column C onwards
I have coded it but its not working.
Private Sub CommandButton1_Click()
Dim main As Worksheet
Dim outcome As Worksheet
'main sheet contains Range to search number in
Set main = ThisWorkbook.Sheets("Sheet1")
'outcome sheet has specific values in Column B
Set outcome = ThisWorkbook.Sheets("Sheet3")
'column B values are considrered as doubles
Dim valuesfind As Double
'range where values are to be found
Dim myrange As Range
Set myrange = Worksheets("Sheet1").Range("A6:O29")
'no of times to loop code based on values in outcomesheet
locations = Worksheets("Sheet3").Cells(Rows.Count, 2).End(xlUp).Row
For i = 6 To locations
degrees = outcome.Range("B" & i).Value
For b = 6 To Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
If main.Range("A6:O29" & b).Value = degrees Then
outecome.Range("C:BR" & i).Value = main.Range("Q:CF" & b).Value
Exit For
End If
Next b
Next i
End Sub
[1]: https://i.stack.imgur.com/uBo66m.png
[2]: https://i.stack.imgur.com/D0bRUm.png
Please remember to declare all variables, add Option Explicit at the top of your module to help you enforce it.
Try the code below:
Option Explicit
Private Sub CommandButton1_Click()
'main sheet contains Range to search number in
Dim main As Worksheet
Set main = ThisWorkbook.Sheets("Sheet1")
Const mainCopyRng As String = "Q?:CF?"
'outcome sheet has specific values in Column B
Dim outcome As Worksheet
Set outcome = ThisWorkbook.Sheets("Sheet3")
Const outcomePasteRng As String = "C?:BR?"
'range where values are to be found
Dim myrange As Range
Set myrange = main.Range("A6:O29")
'no of times to loop code based on values in outcomesheet
Dim outcomeLastRow As Long
outcomeLastRow = outcome.Cells(Rows.Count, 2).End(xlUp).Row
Dim i As Long
For i = 6 To outcomeLastRow
Dim Degrees As Double
Degrees = outcome.Cells(i, 2).Value
Dim searchRng As Range
Set searchRng = myrange.Find(Degrees, LookIn:=xlValues, LookAt:=xlWhole)
If Not searchRng Is Nothing Then
Dim searchRow As Long
searchRow = searchRng.Row
outcome.Range(Replace(outcomePasteRng, "?", i)).Value = main.Range(Replace(mainCopyRng, "?", searchRow)).Value
End If
Next i
End Sub
This should work.
Sub Test()
Dim main As Worksheet
Set main = ThisWorkbook.Sheets("Sheet1")
Dim myrange As Range
Set myrange = main.Range("A6:O29")
Dim outcome As Worksheet
Set outcome = ThisWorkbook.Sheets("Sheet3")
'Set reference to locations in sheet3.
Dim locations As Range
With outcome
Set locations = .Range(.Cells(1, 2), .Cells(Rows.Count, 2).End(xlUp))
End With
'Search for each location in Sheet1 and if found copy to Sheet3.
Dim location As Range
Dim FoundLocation As Range
For Each location In locations
Set FoundLocation = myrange.Find( _
What:=location, _
After:=myrange.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext)
If Not FoundLocation Is Nothing Then
main.Cells(FoundLocation.Row, 1).Resize(, 15).Copy _
Destination:=location.Offset(, 1)
End If
Next location
End Sub
I would like to be able to copy the selected row from sheet 3 range B: G and paste the cells to sheet 4 column A: F
but when the operation ends I find the formatting in the A: F range and the pasted data in the B: G range Thanks
Sub Elimina_selezione()
Worksheets(3).Activate
ActiveSheet.Unprotect
Call copia_archivio
Worksheets(3).Activate
ActiveCell.EntireRow.Delete
Sheets(3).Protect
End Sub
Sub copia_archivio()
Dim i As Range
Dim rig As Long
Sheets(3).Select
ActiveCell.EntireRow.Copy
Worksheets(4).Activate
ActiveSheet.Unprotect
With Sheets(4).Range("A" & Rows.Count).End(xlUp).Offset(1)
.PasteSpecial Paste:=xlPasteValues, Transpose:=False
With Intersect(.EntireRow, .Parent.Columns("A:F"))
.Interior.ColorIndex = 44
.Borders.LineStyle = XlLineStyle.xlContinuous
End With
End With
End Sub
Better to use range and worksheet variables where possible. The only activation necessary is to get the selection on sheet3, I think. (tested code)
Sub CopyRowFromSheet3to4andDeleteRow()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsSrc As Worksheet: Set wsSrc = wb.Worksheets("Sheet3")
Dim wsTgt As Worksheet: Set wsTgt = wb.Worksheets("Sheet4")
wsSrc.Activate 'need to activate it to get its selected range
Dim rSel As Range: Set rSel = wb.Windows(1).Selection 'window(1) is always the active worksheet
Dim iSelRow As Long: iSelRow = rSel.Row
Dim rSrc As Range: Set rSrc = wsSrc.Range("B" & iSelRow & ":G" & iSelRow)
Dim iTgtRow As Long: iTgtRow = wsTgt.Range("A" & wsTgt.Rows.Count).End(xlUp).Row + 1
Dim rTgt As Range: Set rTgt = wsTgt.Range("A" & iTgtRow & ":F" & iTgtRow)
rSrc.Copy rTgt
rTgt.Interior.ColorIndex = 44
rTgt.Borders.LineStyle = XlLineStyle.xlContinuous
Dim rDelSrcRow As Range: Set rDelSrcRow = wsSrc.Range(iSelRow & ":" & iSelRow)
rDelSrcRow.Delete xlShiftUp
End Sub
You are saying that you copy the selected row from sheet 3 range B: G. As far as I understand you are trying to copy not the whole row but only the range of intersection with columns b:g. But your code copies the whole row starting from column A, not B.
You should re-code the range you want to copy and replace "activecell.entirerow" with it.
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
There are a lot of threads about this error, but I can't get this to work no matter what I try. Most people say it occurs when you try to invoke a method on an inactive sheet, but you shouldn't have to do that. Error is on line 28. Thanks.
Private Sub CommandButton1_Click()
Dim x As Integer
Dim boisePaste As Integer
Dim jrgPaste As Integer
Dim master As Integer
Dim lastRow As Integer
Dim bookCount As Integer
bookCount = Application.Workbooks.Count
For x = 1 To bookCount
If Left(Application.Workbooks(x).Name, 14) = "ITEM_INVENTORY" Then
boisePaste = x
ElseIf Left(Application.Workbooks(x).Name, 6) = "report" Then
jrgPaste = x
ElseIf Left(Application.Workbooks(x).Name, 8) = "Portland" Then
master = x
End If
next x
'Unhide sheets and delete Boise range'
Application.ActiveWorkbook.Sheets("BoisePaste").Visible = True
Sheets("JRGpaste").Visible = True
lastRow = Sheets("BoisePaste").Cells(Rows.Count, "B").End(xlUp).Row
Sheets("BoisePaste").Range(Cells(1,2), Cells(lastRow, 23)).Clear
'Open Boise file and copy range, paste in master'
Application.Workbooks(boisePaste).Activate
With ActiveSheet
.Range(.Cells(1,1), .Cells((.Cells(Rows.Count, "A").End(xlUp).Row),22)).Copy
End With
Application.Workbooks(master).Sheets("BoisePaste").Range(B1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'Open JRG report and copy range, paste in master'
Application.Workbooks(jrgPaste).Activate
ActiveSheet.Cells.Copy
Application.Workbooks(master).Sheets("JRGpaste").Range(A1).Paste
Application.CutCopyMode = False
'Refresh pivot tables; hide sheets'
Application.Workbooks(master).Activate
With ActiveWorkbook
.RefreshAll
.RefreshAll
.Sheets("BoisePaste").Visible = False
.Sheets("BoisePaste").Visible = False
End With
End Sub
You need to explicitly state which sheet you want the Rows.Count and other such Range uses (Columns,Rows,Cells,etc.) will be on.
Try this:
Sheets("BoisePaste").Range(Sheets("BoisePaste").Cells(1,2), Sheets("BoisePaste").Cells(lastRow, 23)).Clear
So, go through your code and make sure you do this everywhere...i.e. in .Range(.Cells(1,1), .Cells((.Cells(Rows.Count, "A").End(xlUp).Row),22)).Copy, you didn't do it to Rows.Count, so add the sheet there too, to prevent any unexpected actions.
Think of it like this perhaps, with the line
myVariable = Sheets("mySheet").Range(Cells(1,1),Cells(1,2)).Value
VBA is reading that as
In mySheet, look for a range. What range? Hm, the user says Cells(1,1) and Cells(1,2), but what sheet does he want that? The current activesheet is called yourSheet...He specified where the Range should be (sheet called mySheet), but he didn't on Cells(), so I don't know what he wants! mySheet cells(1,1) or yourSheet cells(1,1) ??
(and yes, that's exactly how a computer thinks :P)
Edit: I went through and tried to help tighten up your code. But, as you can see perhaps, I'm not quite positive as to what you want to do, but this should give you some help/insight:
Private Sub CommandButton1_Click()
Dim x As Integer
Dim boisePaste As Integer
Dim jrgPaste As Integer
Dim master As Integer
Dim lastRow As Integer
Dim bookCount As Integer
bookCount = Application.Workbooks.Count
' Create variables to hold the workbook and sheet names.
Dim jrgWS As Worksheet, boiseWS As Worksheet
Dim masterWB As Workbook
Set masterWB = Workbooks(master)
Set jrgWS = Sheets("JRGPaste")
Set boiseWS = Sheets("BoisePaste")
For x = 1 To bookCount
If Left(Application.Workbooks(x).Name, 14) = "ITEM_INVENTORY" Then
boisePaste = x
ElseIf Left(Application.Workbooks(x).Name, 6) = "report" Then
jrgPaste = x
ElseIf Left(Application.Workbooks(x).Name, 8) = "Portland" Then
master = x
End If
Next x
'Unhide sheets and delete Boise range'
Application.ActiveWorkbook.Sheets("BoisePaste").Visible = True
jrgWS.Visible = True
With boiseWS
lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
.Range(.Cells(1, 2), .Cells(lastRow, 23)).Clear
End With
'Open Boise file and copy range, paste in master'
'' DONT USE ACTIVE SHEET! Use your variables instead
'Application.Workbooks(boisePaste).Activate
With boiseWS
'Since you want values (xlPasteValues), just set the two ranges equal instead of copy/paste
.Range("B1").Value = .Range(.Cells(1, 1), .Cells((.Cells(.Rows.Count, "A").End(xlUp).Row), 22)).Value
End With
'Open JRG report and copy range, paste in master'
' The below just pastes into the same sheet, no??
jrgWS.Cells.Copy
jrgWS.Range("A1").Paste
Application.CutCopyMode = False
'Refresh pivot tables; hide sheets'
Application.Workbooks(master).Activate
With ActiveWorkbook
.RefreshAll
.RefreshAll
.Sheets("BoisePaste").Visible = False
End With
End Sub
I have a spreadsheet that calls out jobs with agents assigned. The "agent ID" is in column A, with data in columns A-M.
I have separate sheets for each of the agent's supervisor (supervisor last name). I was hard coding the agent ID into the macro but I would like to make it work so I could pull that data from a translation sheet which would hold nothing more than the agent ID and corresponding supervisor last name. I can't figure out how to parse through the data row by row, find the agent id, then copy that row to the corresponding sheet.
I already have the translation sheet (named sup-agent_Trans) with AgentID, Supervisor; that's it, those two columns.
Here is what I have so far:
Dim varList As Variant
Dim lstRowTrans As Long
Dim lstRowRework As Long
Dim rngArr As Range
Dim rngRwk As Range
Dim row As Range
Dim cell As Range
Application.ScreenUpdating = False
lstRowTrans = Worksheets("Tech-Sup_Trans").Cells(Rows.Count, "A").End(xlUp).row
lstRowRework = Worksheets("Rework").Cells(Rows.Count, "A").End(xlUp).row
varList = Sheets("Tech-Sup_Trans").Range("A1:B" & lstRowTrans)
Set rngRwk = Sheets("Rework").Range("A1:A" & lstRowRework)
For Each cell In rngRwk
For i = LBound(varList, 2) To UBound(varList, 2) 'columns
If i = cell(i).Value <> "" Then
For j = LBound(varList, 1) To UBound(varList, 1) 'rows
If varList(j, cell(i).Value) Then
IsInArray = True
End If
Next j
End If
Next i
Next cell
So after someone so graciously pointed out that I don't need to use an array, I used the "Find" function for a range and figured it out. Thanks findwindow!
Dim shtRwk As Worksheet
Dim shtRef As Worksheet
Dim DestCell As Range
Dim rngRwk As Range
Dim lstRowTrans As Long
Dim lstRowRework As Long
Dim rngArr As Range
Dim row As Range
Dim cell As Range
Dim strSup As String
Set shtRwk = Sheets("Rework")
Set shtRef = Sheets("Tech-Sup_Trans")
Application.ScreenUpdating = False
lstRowTrans = shtRef.Cells(Rows.Count, "A").End(xlUp).row
lstRowRework = shtRwk.Cells(Rows.Count, "A").End(xlUp).row
Set rngRwk = Sheets("Rework").Range("A2:A" & lstRowRework)
For Each cell In rngRwk
With shtRef.Range("A1:B" & lstRowTrans)
Set DestCell = .Find(What:=cell.Value, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not DestCell Is Nothing Then
strSup = DestCell.Offset(0, 1).Value
cell.EntireRow.Copy
Sheets(strSup).Select
ActiveSheet.Range("A65536").End(xlUp).Select
Selection.Offset(1, 0).Select
ActiveSheet.Paste
shtRwk.Select
Else
MsgBox "No Sup found for tech " & cell.Value
End If
End With
Next cell
Application.ScreenUpdating = True