I having difficulty copying specific columns into another sheet.
Sub FindthenCopy()
'Excel VBA find the position of a header
Dim source As Range
Set ws1 = Worksheets("CheckSheet")
For i = 1 To 50
If Sheets(ActiveSheet.Name).Cells(1, i).Value = "User ID" Then
Sheets(ActiveSheet.Name).Columns(i).Select
Set source = Selection
source.Copy ([ws1])
Exit For
End If
Next i
End Sub
Your problem is you're specifying the destination as a worksheet, it needs to be a cell
source.Copy ([ws1])
should be
source.copy ws1.range("A1") 'or whichever column you want - must be row 1 though
as #HarassedDad already told you, you must specify a starting cell in thebsheet you want to past values
furthermore ActiveSheet is the default implicit sheet reference assumed and you don't need all that Select and Selection:
Sub FindthenCopy()
Dim ws1 As Worksheet
Set ws1 = Worksheets("CheckSheet")
Dim i As Long
For i = 1 To 50
If Cells(1, i).Value = "User ID" Then
Columns(i).Copy ws1.Cells(1, 1)
Exit For
End If
Next i
End Sub
you may also want to use Find() method and avoid looping:
Sub FindthenCopy()
Dim source As Range
Set source = Rows(1).Find(what:="User ID", LookIn:=xlValues, lookat:=xlPart)
If Not source Is Nothing Then source.EntireColumn.Copy Worksheets("CheckSheet").Cells(1, 1)
End Sub
or, if you know for sure that "User ID" string is to be found in active sheet row 1:
Sub FindthenCopy()
Rows(1).Find(what:="User ID", LookIn:=xlValues, lookat:=xlPart).EntireColumn.Copy Worksheets("CheckSheet").Cells(1, 1)
End Sub
Try sth like this:
Option Explicit
Sub CopyCol()
Dim source As Range
Dim i As Integer
Dim ws As Worksheet
Set ws = ActiveSheet
For i = 1 To 50
If ws.Cells(1, i) = "User ID" Then
ws.Columns(i).Select
Selection.Copy
Worksheets.Add 'Add new sheet
ActiveSheet.Cells(1, 1).Select ' select a cell where your data
'suppose to be copy to
ActiveCell.PasteSpecial (xlPasteAll) 'paste data
Exit For
End If
Next i
End Sub
Related
I have 10 sheets in a workbook - These sheets were imported from individual workbooks - These workbooks were extracts from different monitoring tools
I need to apply a filter across all 10 worksheets, however, not all the sheets are in the same format/structure.
With 6 of the worksheets, the column headers are the same and in the same order.
The remaining 4 sheets have different headers. For example: The filter needs to look for a header name Status - This works for the 6 sheets that have the same structure, however, the other 4 sheets have the following:
wsheet1:
User Status instead of Status - I need to change the header to Status
wsheet2:
Current_Status instead of Status - I need to change the header to Status
Below is sample code that is supposed to manipulate the specified sheet in in order to have it "look" the same as the others, however, I am having some really annoying issues where the code isn't applied to the sheet specified and is instead applied to the "Activesheet" when the macro is executed.
Here is the code I have:
Sub arrangeSheets()
Dim lastCol As Long, idCount As Long, nameCount As Long, headerRow As Long
Dim worksh As Integer, WS_Count As Integer, i As Integer, count As Integer
Dim rng As Range, cel As Range, rngData As Range
Dim worksheetexists As Boolean
worksh = Application.Sheets.count
worksheetexists = False
headerRow = 1 'row number with headers
lastCol = Cells(headerRow, Columns.count).End(xlToLeft).Column 'last column in header row
idCount = 1
nameCount = 1
' Set WS_Count equal to the number of worksheets in the active
' workbook.
WS_Count = ActiveWorkbook.Worksheets.count
'If Application.Match finds no match it will throw an error so we need to skip them
On Error Resume Next
For x = 1 To worksh
If Worksheets(x).Name = "wsheet1" Then
worksheetexists = True
Set rng = Sheets("wsheet1").Range(Cells(headerRow, 1), Cells(headerRow, lastCol)) 'header range
With Worksheets("wsheet1").Name
Rows(2).Delete
Rows(1).Delete
count = Application.Match("*USER STATUS*", Worksheets("wsheet1").Range("A1:AZ1"), 0)
If Not IsError(count) Then
For Each cel In rng 'loop through each cell in header
If cel = "*USER STATUS*" Then 'check if header is "Unit ID"
cel = "STATUS" & idCount 'rename "Unit ID" using idCount
idCount = idCount + 1 'increment idCount
End If
Next cel
End If
End With
Exit For
End If
Next x
End Sub
Consider using ., in the With-End with section to refer to the Worksheet mentioned:
The Like in If cel Like "*USER STATUS*" works with the *, thus will be evaluated to True for 12USER STATUS12 or anything similar.
The count variable should be declared as variant, thus it can keep "errors" in itself.
This is how the code could look like:
With Worksheets("wsheet1")
.Rows(2).Delete
.Rows(1).Delete
Count = Application.Match("*USER STATUS*", .Range("A1:AZ1"), 0)
If Not IsError(Count) Then
For Each cel In Rng 'loop through each cell in header
If cel Like "*USER STATUS*" Then 'check if header is "Unit ID"
cel = "STATUS" & idCount 'rename "Unit ID" using idCount
idCount = idCount + 1 'increment idCount
End If
Next cel
End If
End With
If you want the same headers across all sheets in the workbook you could just copy the headers from the first sheet and paste them on each sheet.
This wouldn't work if your column order is different across sheets, but from the example you gave it's just renaming columns rather than re-ordering?
Sub CorrectHeaders()
Dim cpyRng As Range
With ThisWorkbook
If .Worksheets.count > 1 Then
With .Worksheets(1)
Set cpyRng = .Range(.Cells(1, 1), .Cells(1, .Columns.count).End(xlToLeft))
End With
.Sheets.FillAcrossSheets cpyRng
End If
End With
End Sub
If the column headers are in different orders, but you just want to replace any cell that contains the text "Status" with just "Status" then you could use Replace. You may want to add an extra condition of MatchCase:=True.
Sub Correct_Status()
Dim wrkSht As Worksheet
For Each wrkSht In ThisWorkbook.Worksheets
wrkSht.Cells(1, 1).EntireRow.Replace What:="*Status*", Replacement:="Status", LookAt:=xlWhole
Next wrkSht
End Sub
I have additional solution which has also helped with this issue. Code below:
Sub ManipulateSheets()
Dim worksh As Integer
Dim worksheetexists As Boolean
worksh = Application.Sheets.count
worksheetexists = False
'If Application.Match finds no match it will throw an error so we need to skip them
On Error Resume Next
Worksheets("wSheet1").Activate
With Worksheets("wSheet1")
.Rows(2).Delete
.Rows(1).Delete
End With
Worksheets("wSheet2").Activate
With Worksheets("wSheet2")
.Rows(2).Delete
End With
End Sub
I am fairly new to VBA and Wondering if someone can help me out.
I have 2 different sheets in a workbook.
Sheet(Raw Data) has a range with Cost Center NameS (Cell BC3 down to empty)
I have to copy Sheet(CC Template) and name it the right 5 characters of Sheet(Raw Data).Range(BC3).Value and change Cell(2,2).value to Sheet(Raw Data).Range(BC3).Value...
Then I want it to go to the next cell in Sheet(Raw Data) ...BC4 and create the second sheet and change the name and Cell(2,2) accordingly until the list in Sheet(Raw Data) ends.
Here is my Code. It creates the first worksheet but then I get run-time Error '1004' at Sheets("Raw Data").Range("BC3").Select in the do until loop. I would like to get rid of X and CCName variable from the code also if possible.
Sub CreateCCTabsinNewPlantFile2()
Dim i As Integer
Dim x As Integer
Dim CCName As String
i = ActiveWorkbook.Worksheets.Count
x = 1
' Select cell BC3, *first line of data*.
Sheets("Raw Data").Range("BC3").Select
' Set Do loop to stop when an empty cell is reached.
Do Until IsEmpty(ActiveCell)
CCName = ActiveCell.Value
' Code to make worksheets
Worksheets("CC Template").Copy after:=Worksheets(i)
ActiveSheet.Name = Right(CCName, 5)
ActiveSheet.Cells(2, 2).Value = CCName
' Step down 1 row from present location.
Sheets("Raw Data").Range("BC3").Select
ActiveCell.Offset(x, 0).Select
x = x + 1
Loop
End Sub
Sub CreateCCTabsinNewPlantFile2()
Dim i As Integer
Dim X As Integer
X = 3 'Starting row in Sheet("Raw Data")
With ThisWorkbook.Sheets("Raw Data")
Do Until .Cells(X, 55).Value = "" 'cells(x,55)= BC3. First time x= 3 so Cells(3,55)=BC3
i = ThisWorkbook.Worksheets.Count 'we update count everytime, because we are adding new sheets
ThisWorkbook.Worksheets("CC Template").Copy after:=ThisWorkbook.Worksheets(i)
ThisWorkbook.ActiveSheet.Name = Right(.Cells(X, 55).Value, 5)
ThisWorkbook.ActiveSheet.Cells(2, 2).Value = .Cells(X, 55).Value
' We increade X. That makes check a lower rower in next loop.
X = X + 1
Loop
End With
End Sub
Hope this helps.
You get error1004 because you can use Range.Select only in Active Sheet. If you want to Select a Range in different Sheet, first you must Activate that sheet with Sheets("Whatever").Activate.
Also, I Updated your code so you can execute it from any sheet. Your code forces user to have Sheets ("Raw Data") as the ActiveSheet.
Try not use too much Select if you can avoid it. And also , try to get used to Thisworkbook instead of ActiveWorkbook. If you work always in same workbook, is not a problem, but if your macros operate several workbooks, you'll need to difference when to use each one.
Try this code
Sub Test()
Dim rng As Range
Dim cel As Range
With Sheets("Raw Data")
Set rng = .Range("BC3:BC" & .Cells(Rows.Count, "BC").End(xlUp).Row)
End With
Application.ScreenUpdating = False
For Each cel In rng
If Not SheetExists(cel.Value) Then
Sheets("CC Template").Copy After:=Sheets(Sheets.Count)
With ActiveSheet
.Name = Right(cel.Value, 5)
.Range("B2").Value = cel.Value
End With
End If
Next cel
Sheets("Raw Data").Activate
Application.ScreenUpdating = True
End Sub
Function SheetExists(sheetName As String) As Boolean
On Error Resume Next
SheetExists = (LCase(Sheets(sheetName).Name) = LCase(sheetName))
On Error GoTo 0
End Function
I need to use a macro that will copy and paste an entire row based on whether the text of a cell matches another. I looked for something similar on the site but was not able to find something that could help. I'll outline the process I am trying to do:
Copy and paste a list of program names (the number of names can vary) from one sheet to another. (this one I have already completed)
Check each program name (number of programs can vary) individually to see if it matches a separate list on a separate sheet.
If it matches, copy and paste the entire row, if it doesn't, move to the next.
I tried using if and then statements, but I was having issues trying to loop it (if thats the correct term). The size of the list can vary, so making sure that this is taking into account in the macro is important. Here is what I have so far:
Copy and paste the initial list function
Sub Report_P1()
Dim wsPivot As Worksheet: Set wsPivot = ThisWorkbook.Sheets("Pivot")
Dim wsReport As Worksheet: Set wsReport = ThisWorkbook.Sheets("Report")
wsPivot.Select
Range("A4", Range("A65536").End(xlUp)).Select
Application.CutCopyMode = False
Selection.Copy
wsReport.Select
Range("A3").Select
ActiveSheet.Paste
End Sub
The filter tool I need help with
Sub Report_P2()
Dim i As Integer
Dim j As Integer
Dim wsReport As Worksheet: Set wsReport = ThisWorkbook.Sheets("Report")
Dim wsData As Worksheet: Set wsData = ThisWorkbook.Sheets("Data")
For i = 1 To 10
If wsReport.Cells(i, 1) = wsData.Cells(i, 1) Then
wsData.Select
Range(i).Select
'Application.CutCopyMode = False
Range(i).Copy
wsReport.Select
Range(i).Select
ActiveSheet.Paste
End If
Next i
End Sub
Thank you for your help!
Sub Report_P2()
Dim i As Integer
Dim j As Integer
Dim wsReport As Worksheet: Set wsReport = ThisWorkbook.Sheets("Report")
Dim wsData As Worksheet: Set wsData = ThisWorkbook.Sheets("Data")
For i = 1 To 10
If wsReport.Cells(i, 1) = wsData.Cells(i, 1) Then
wsData.Select
Rows(i).Select
Selection.Copy
wsReport.Activate
Range("A" & i).Activate
ActiveSheet.Paste
End If
Application.CutCopyMode = False
Next i
End Sub
Or more concisely:
For i = 1 To 10
If wsReport.Cells(i, 1) = wsData.Cells(i, 1) Then
wsData.Rows(i).Copy Destination:=wsReport.Range("A" & i)
End If
Next i
I want to copy a table into a new Workbook while choosing which range I want to copy and knowing that the first Columns ("A") is automatically copied. (rows are not a problem, all of them have to be copied)
For example, i have a table composed of 28 rows and 10 columns. Added to A1:A28 (first columns, all rows),i want just to copy the column 5 and 8 with all its rows.
That's what i have until now but it doesn't work.
Sub CommandButton1_Click()
Dim newWB As Workbook, currentWB As Workbook
Dim newS As Worksheet, currentS As Worksheet
Dim CurrCols As Variant
Dim rng As rang
'Copy the data you need
Set currentWB = ThisWorkbook
Set currentS = currentWB.Sheets("Feuil1")
'select which columns you want to copy
CurrCols = InputBox("Select which column you want to copy from table (up to 10)")
If Not IsNumeric(CurrCols) Then
MsgBox "Please select a valid Numeric value !", vbCritical
End
Else
CurrCols = CLng(CurrCols)
End If
'Set rng = currentWB.currentS.Range(Cells(1, A), Cells(27, CurrCols)).Select
currentS.Range("A1:A27").Select
Selection.copy
Set rng = currentWB.currentS.Range(Cells(1, CurrCols), Cells(28, CurrCols)).Select
rng.copy
'Create a new file that will receive the data
Set newWB = Workbooks.Add
With newWB
Set newS = newWB.Sheets("Feuil1")
newS.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
End Sub
Can you help please solving it? Thanks in advance!
You can't copy a non-continuous range but you can load the data into an array and write it once to the new workbook.
Private Sub CommandButton1_Click()
Dim arData
Dim MyColumns As Range, Column As Range
Dim x As Long, y As Long
On Error Resume Next
Set MyColumns = Application.InputBox(Prompt:="Hold down [Ctrl] and click the columns to copy", Title:="Copy Columns to new Workbook", Type:=8)
On Error GoTo 0
If MyColumns Is Nothing Then Exit Sub
Set MyColumns = Union(Columns("A"), MyColumns.EntireColumn)
Set MyColumns = Intersect(MyColumns, ActiveSheet.UsedRange)
ReDim arData(1 To MyColumns.Rows.Count, 1 To 1)
For Each Column In MyColumns.Columns
y = y + 1
If y > 1 Then ReDim Preserve arData(1 To MyColumns.Rows.Count, 1 To y)
For x = 1 To Column.Rows.Count
arData(x, y) = Column.Rows(x)
Next
Next
With Workbooks.Add().Worksheets(1)
.Range("A1").Resize(UBound(arData, 1), UBound(arData, 2)) = arData
.Columns.AutoFit
End With
End Sub
try this (commented) code
Option Explicit
Sub CommandButton1_Click()
Dim newSht As Worksheet
Dim currCols As String
Dim area As Range
Dim iArea As Long
Set newSht = Workbooks.add.Worksheets("Feuil1") '<--| add a new workbook and set its "Feuil1" worksheet as 'newSht'
currCols = Replace(Application.InputBox("Select which column you want to copy from table (up to 10)", "Copy Columns", "A,B,F", , , , , 2), " ", "") '<--| get columns list
With ThisWorkbook.Worksheets("Feuil1") '<--| reference worksheet "Feuil1" in the workbook this macro resides in
For Each area In Intersect(.Range(ColumnsAddress(currCols)), .Range("A1:G28")).Areas ' loop through referenced worksheet areas of the range obtained by crossing its listed columns with its range "A1:G28"
With area '<--| reference current area
newSht.Range("A1").Offset(, iArea).Resize(.Rows.Count, .Columns.Count).value = .value '<--| copy its values in 'newSht' current column offset from "A1" cell
iArea = iArea + .Columns.Count '<--| update current column offset from 'newSht' worksheet "A1" cell
End With
Next area
End With
End Sub
Function ColumnsAddress(strng As String) As String
Dim elem As Variant
For Each elem In Split(strng, ",")
ColumnsAddress = ColumnsAddress & elem & ":" & elem & ","
Next
ColumnsAddress = Left(ColumnsAddress, Len(ColumnsAddress) - 1)
End Function
I think you can copy all column to a temp sheet and then write some code to delete the useless column. finally paste the table to your expected area.
I have a worksheet that has multiple value and what I would like to do is search say column "B" for a value and when it finds it to copy the complete row and paste it somewhere else. I have a similar function to do this but it stops after it finds the first one which is fine for the situation that I am using it in but for this case I need it to copy all that match. below is the code that im using at the moment that only gives me one value
If ExpIDComboBox.ListIndex <> -1 Then
strSelect = ExpIDComboBox.value
lastRow = wks1.range("A" & Rows.Count).End(xlUp).row
Set rangeList = wks1.range("A2:A" & lastRow)
On Error Resume Next
row = Application.WorksheetFunction.Match(strSelect, wks1.Columns(1), 0) ' searches the worksheet to find a match
On Error GoTo 0
If row Then
Thanks
I would suggest to load data into array first and then operate on this array instead of operating on cells and using Worksheet functions.
'(...)
Dim data As Variant
Dim i As Long
'(...)
If ExpIDComboBox.ListIndex <> -1 Then
strSelect = ExpIDComboBox.Value
lastRow = wks1.Range("A" & Rows.Count).End(xlUp).Row
'Load data to array instead of operating on worksheet cells directly - it will improve performance.
data = wks1.Range("A2:A" & lastRow)
'Iterate through all the values loaded in this array ...
For i = LBound(data, 1) To UBound(data, 1)
'... and check if they are equal to string [strSelect].
If data(i, 1) = strSelect Then
'Row i is match, put the code here to copy it to the new destination.
End If
Next i
End If
I have used the Range.Find() method to search each row. For each row of data which it finds, where the value you enter matches the value in column G, it will copy this data to Sheet2. You will need to amend the Sheet variable names.
Option Explicit
Sub copyAll()
Dim rngFound As Range, destSheet As Worksheet, findSheet As Worksheet, wb As Workbook
Dim strSelect As String, firstFind As String
Set wb = ThisWorkbook
Set findSheet = wb.Sheets("Sheet1")
Set destSheet = wb.Sheets("Sheet2")
strSelect = ExpIDComboBox.Value
Application.ScreenUpdating = False
With findSheet
Set rngFound = .Columns(7).Find(strSelect, LookIn:=xlValues)
If Not rngFound Is Nothing Then
firstFind = rngFound.Address
Do
.Range(.Cells(rngFound.Row, 1), .Cells(rngFound.Row, _
.Cells(rngFound.Row, .Columns.Count).End(xlToLeft).Column)).Copy
destSheet.Cells(destSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial Paste:=xlPasteAll
Set rngFound = .Columns(2).Find(strSelect, LookIn:=xlValues, After:=.Range(rngFound.Address))
Loop While firstFind <> rngFound.Address
End If
End With
Application.ScreenUpdating = True
End Sub
I've assumed you will have data between columns A:G?
Otherwise you can just amend the .Copy and .PasteSpecial methods to fit your requirements.
Thanks for your replys. I tired to use both methods but for some reason they did not seem to work. They did not give me an error they just did not produce anything.#mielk I understand what you mean about using an array to do this and it will be a lot faster and more efficent but I dont have enfough VBA knowledge to debug as to why it did not work. I tried other methods and finally got it working and thought it might be usefull in the future for anybody else trying to get this to work. Thanks once again for your answers :)
Private Sub SearchButton2_Click()
Dim domainRange As range, listRange As range, selectedString As String, lastRow As Long, ws, wks3 As Excel.Worksheet, row, i As Long
Set wks3 = Worksheets("Exceptions") '<----- WorkSheet for getting exceptions
If DomainComboBox.ListIndex <> -1 Then '<----- check that a domain has been selected
selectedString = DomainComboBox.value
lastRow = wks3.range("A" & Rows.Count).End(xlUp).row ' finds the last full row
Set listRange = wks3.range("G2:G" & lastRow) 'sets the range from the top to the last row to search
i = 2
'used to only create a new sheet is something is found
On Error Resume Next
row = Application.WorksheetFunction.Match(selectedString, wks3.Columns(7), 0) ' searches the worksheet to find a match
On Error GoTo 0
If row Then
For Each ws In Sheets
Application.DisplayAlerts = False
If (ws.Name = "Search Results") Then ws.Delete 'deletes any worksheet called search results
Next
Application.DisplayAlerts = True
Set ws = Sheets.Add(After:=Sheets(Sheets.Count)) 'makes a new sheet at the end of all current sheets
ws.Name = "Search Results" 'renames the worksheet to search results
wks3.Rows(1).EntireRow.Copy 'copys the headers from the exceptions page
ws.Paste (ws.Cells(, 1)) 'pastes the row into the search results page
For Each domainRange In listRange ' goes through every value in worksheet trying to match what has been selected
If domainRange.value = selectedString Then
wks3.Rows(i).EntireRow.Copy ' copys the row that results was found in
emptyRow = WorksheetFunction.CountA(ws.range("A:A")) + 1 ' finds next empty row
ws.Paste (ws.Cells(emptyRow, 1)) 'pastes the contents
End If
i = i + 1 'moves onto the next row
ws.range("A1:Q2").Columns.AutoFit 'auto fit the columns width depending on what is in the a1 to q1 cell
ws.range("A1:Q1").Cells.Interior.ColorIndex = (37) 'fills the header with a colour
Application.CutCopyMode = False 'closes the paste funtion to stop manual pasting
Next domainRange ' goes to next value
Else
MsgBox "No Results", vbInformation, "No Results" 'display messgae box if nothing is found
Exit Sub
End If
End If
End Sub
Thanks.
N.B. this is not the most efficent way of doing this read mielk's answer and the other answer as they are better if you can get them working.