I want to copy and paste a range from a fixed worksheet ("c4:c178") into a variable worksheet.
I have two dropdowns, one has a list of all the worksheet names and the other has the column number.
My hope is the user could select the worksheet name and column reference in the drop-down and then click the macro button to copy and paste the range to that reference.
Sub CopyPaste()
Dim Sheetname As String
Sheetname = ActiveSheet.Range("i3").Value
Dim Col As Long
Col = ActiveSheet.Range("i4").Value
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Tracking Only")
Dim rng As Range
Set rng = ActiveSheet.Range("c4:C178")
With rng
ws.Cells(4, Col).Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
End Sub
I receive
"Run-time error '1004': Application-define or object-defined error"
It highlights the ws.cells code.
Break your process into steps, store the dropdown values using variables, and assign the .Value of the source range to the target range.
With ThisWorkbook.Worksheets("Tracking Only")
Dim sheetName As String
sheetName = .Range("I3").Value
Dim col As Long
col = .Range("I4").Value
Dim rng As Range
Set rng = .Range("C4:C178")
End With
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(sheetName)
With rng
ws.Cells(4, col).Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
Related
Option Explicit
Sub ActivityMatching()
Dim wsToLook As Worksheet
Set wsToLook = ThisWorkbook.Sheets("DataOra")
Dim rngToLook As Range
Set rngToLook = wsToLook.Range("A2:H1000")
Dim wsMain As Worksheet
Set wsMain = ThisWorkbook.Sheets("Sheet2")
Dim iCell As Range
Dim rngToInsert As Range
Dim lastRow As Long
Dim whatToFind As Variant
With wsMain
.Range("A1:M1").AutoFilter Field:=1, Criteria1:="Dialer Attempt"
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rngToInsert = .Range("K2:K" & lastRow).SpecialCells(xlCellTypeVisible)
For Each iCell In rngToInsert
whatToFind = iCell.Offset(, -10).Value
iCell.Value = Application.VLOOKUP(CLng(whatToFind), rngToLook, 7, False)
Next iCell
End With
End Sub
Sheet "Sheet2" column A- the key, column K where I want to put the values
Sheet "DataOra" column A the key, column G the values.
enter image description here
I received 2042 error. All the values are #N/A
enter image description here
Hi I have an issue with my code. I'm creating 4 new sheets and I'm copying a table into each one (dbR) and a range Range("B8:K8") which is a header. I'm trying to maintain the format of this range while copying, but when I run this code, the row flickers and copies nothing without showing error. Is there something I'm missing? I'm fairly new so I expect my code looks quite poor.
Sub CreateSheets()
Dim rng As Range: Set rng = ThisWorkbook.Worksheets("Configuration").Range("Vendors[Vendors]")
Dim dbR As Range: Set dbR = Sheets("Configuration").ListObjects("Client_Responses").DataBodyRange
Dim Ws_Name As String
For Each cell In rng
Ws_Name = cell
Worksheets.Add.Name = cell
ActiveSheet.Name = cell
dbR.Copy Destination:=Range("B2")
Worksheets("Configuration").Range("B8:K8").Copy
Worksheets(Ws_Name).Range("B1").PasteSpecial Paste:=xlPasteColumnWidths
Next cell
End Sub
Just add the multiple desired 'special paste's:
Sub CreateSheets()
Dim rng As Range: Set rng = ThisWorkbook.Worksheets("Configuration").Range("Vendors[Vendors]")
Dim dbR As Range: Set dbR = Sheets("Configuration").ListObjects("Client_Responses").DataBodyRange
Dim Ws_Name As String
Dim cell
For Each cell In rng
Ws_Name = cell
Worksheets.Add.Name = cell
ActiveSheet.Name = cell
dbR.Copy Destination:=Range("B2")
Worksheets("Configuration").Range("B8:K8").Copy
Worksheets(Ws_Name).Range("B1").PasteSpecial xlPasteColumnWidths
Worksheets(Ws_Name).Range("B1").PasteSpecial xlValues
Worksheets(Ws_Name).Range("B1").PasteSpecial xlFormats
Next cell
End Sub
I have two Excel files.
I am trying to do the following:
Search for a value in Sheet one.
When item is found use offset to pick up the adjacent value i.e. 4 columns to the left (same row)
Add the value (in step 2) to sheet two at the end of Row D
Struggling with the third step.
I get method or data member not found.
Sub findOne()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = ThisWorkbook.Sheets("one") ' ref to sheet one
Set ws2 = ThisWorkbook.Sheets("two") ' ref to sheet two
Dim rng As Range
With ws1
' use find on range H
Set rng = Range("H1:H200").Find(What:="busaoc", LookAt:=xlPart)
'- doesn't like this
ws2.Range("D2").End(xlDown).Offset(1, 0) = ws1.rng(.Offset(0, -4))
End With
end Sub
You were not using your With block, but I removed it here since it doesn't seem necessary if this is your complete code. This has also been amended to not crash on the chance your value is actually not found.
Sub findOne()
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("one")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("two")
Dim rng As Range, LR As Long
Set rng = ws1.Range("H1:H200").Find(What:="busaoc", LookAt:=xlPart)
If rng Is Nothing Then
MsgBox "Value not found"
Else
LR = ws2.Range("D" & ws2.Rows.Count).End(xlUp).Offset(1).Row
ws2.Range("D" & LR).Value = rng.Offset(0, -4).Value
End If
End Sub
I'm trying to compare two columns in two different WB let's say A and B which have only column each.
I'd like to msgbox a text whenever the value of cell in the column of A is also in the column of B.
I managed to put values in a variant variable and like now to compare them. I still get a 424 error at the final if statement that checks the correspondance.
Here is the code :
Option Explicit
Sub uniformisation()
Dim range1 As Variant
Dim range2 As Variant
Dim Tab1 As Variant, tab2 As Variant
Dim fichierM As Workbook
Dim fichierF As Workbook
Set fichierF = Workbooks.Open("thepath")
Set fichierMission = Workbooks.Open("thepath")
fichierF.Activate
fichierM.Activate
Dim wsF As Worksheet
Dim wsM As Worksheet
Set wsF = fichierF.Worksheets("test")
Set wsM = fichierM.Worksheets("A")
Dim C As range
Dim D As range
Set C = wsFlex.Columns(1)
Set D = wsMiss.Columns(1)
Dim TotalRows1 As Long
Dim TotalRows2 As Long
With wsF
TotalRows1 = C.Rows(Rows.Count).End(xlUp).Row
Tab1 = range(Cells(2, 1), Cells(TotalRows1, 1)).Value
MsgBox UBound(Tab1)
End With
With wsM
TotalRows2 = Rows(D.Rows.Count).End(xlUp).Row
tab2 = range(Cells(2, 2=1), Cells(TotalRows2, 1))
MsgBox UBound(tab2)
End With
For Each range1 In Tab1
For Each range2 In tab2
If range1.Value = range2.Value Then
MsgBox range1
End If
Next range2
Next range1
fichierM.Close
fichierF.Close
End Sub
Any help would be really apreciated, thanks !
you definitions are all over the place and the code is too long for what it is supposed to do. Also, you have chosen variant which is not really needed for what you want to do. Here is a shorter version that can get you started:
Sub CompareTwoColumns()
Dim rng1 As Range
Dim rng2 As Range
Dim WB1 As Workbook
Dim WB2 As Workbook
'make sure both workbooks are open
Set WB1 = Workbooks.Open("thepath1")
Set WB2 = Workbooks.Open("thepath2")
'loop through both columns and compare
For Each rng1 In WB1.Worksheets("Sheet1").UsedRange.Columns(1).Cells
For Each rng2 In WB2.Worksheets("Sheet1").UsedRange.Columns(1).Cells
If rng1.Value = rng2.Value Then
MsgBox rng1.Value
End If
Next rng2
Next rng1
End Sub
currently the code below will copy two spreadsheets into the macro sheet.
Problem: I want to use Excel cells to specify a file path (from cell A1, A2 or wherever), a sheet name (from cell B1, B2), and a corresponding specified cell range (in cells C1, C2) instead of having to browse to each file with the Application.
Option Explicit
Sub Sample()
Dim wb1 As Workbook: Set wb1 = ThisWorkbook
Dim wb2 As Workbook
Dim i As Long
Dim wsNew As Worksheet
Dim ws As Worksheet: Set ws = wb1.Sheets("Sheet1")
Dim LastRow
Dim sheetName As String
Dim rangeStart As String
Dim rangeEnd As String
Dim ws2 As Worksheet
Dim CellValueToCopy As String
'declare and set your worksheet with your filenames
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get the last row with data by finding the last item in Column A
For i = 2 To LastRow 'loop from Row 2 to Last in Sheet1 of this workbook
Set wb2 = Workbooks.Open(ws.Cells(i, "A")) 'open the file stored in Column A of Sheet1 of this workbook
sheetName = ws.Cells(i, "B")
rangeStart = ws.Cells(i, "C")
rangeEnd = ws.Cells(i, "D")
'wb2.Sheets(ws.Cells(i, "B").Value).range(ws.Cells(i, "C").Value).Copy
Set ws2 = wb2.Worksheets(sheetName)
wb1.Sheets.Add
wb1.ActiveSheet.Name = sheetName + "_added"
' the below is a proof of concept to copy the values
' loop through the range rather than just one cell to get the final copy
CellValueToCopy = ws2.Cells(1, 1)
wb1.ActiveSheet.Cells(1, 1) = CellValueToCopy
' close workbook and reset variables
wb2.Close SaveChanges:=False
Set wb2 = Nothing
Set wsNew = Nothing
Set ws2 = Nothing
Next i
End Sub
How about something like the following, this will loop through your column A, open the given filename, and copy the Range from Column C from the Sheet in Column B and paste into a new sheet in the current workbook:
Option Explicit
Sub Sample()
Dim wb1 As Workbook: Set wb1 = Workbooks("Change from interface to Cell specify range.xlsm")
Dim wb2 As Workbook
Dim i As Long, LastRow As Long
Dim wsNew As Worksheet
Dim ws As Worksheet: Set ws = wb1.Sheets("Sheet1")
'declare and set your worksheet with your filenames, amend as required
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A
For i = 2 To LastRow 'loop from Row 2 to Last in Sheet1 of this workbook
Set wb2 = Workbooks.Open(ws.Cells(i, "A")) 'open the file stored in Column A of Sheet1 of this workbook
wb2.Sheets(ws.Cells(i, "B").Value).Range(ws.Cells(i, "C").Value).Copy
'above specify the sheet from Column B of Sheet1 and the Range from Column C
'if you have starting range at Column C and end range at Column D then the line below will copy the specified range
'wb2.Sheets(ws.Cells(i, "B").Value).Range(ws.Cells(i, "C").Value & ":" & ws.Cells(i, "D").Value).Copy
Set wsNew = wb1.Sheets.Add(After:=wb1.Sheets(wb1.Sheets.Count))
wsNew.Name = "Blah Blah " & (i - 1)
'above add a new sheet and name accordingly, I used the counter i to number the sheets
wsNew.Range("A1").PasteSpecial xlPasteAll
wb2.Close SaveChanges:=False
Set wb2 = Nothing
Set wsNew = Nothing
Next i
End Sub