Copy/paste a row from one worksheet to another produces type mismatch error - excel

This macro is to move records from a master sheet to other sheets based on criteria from column F.
A type mismatch error occurs in the "Termination" case where it is selecting the cell "B2".
I tried several different options, but each ends up with a different error.
Public Sub moveToSheet()
Sheets("Master").Select
' Find the last row of data
FinalRow = Range("E65000").End(xlUp).Row
'Loop through each row
For x = 2 To FinalRow
' Decide where to copy based on column F
ThisValue = Range("F" & x).Value
Select Case True
Case ThisValue = "Hiring "
Sheets("Master").Cells(x, 2).EntireRow.Copy
Sheets("Hiring").Select
Sheets("Hiring").Range("B2:W2500").Clear
Sheets("Hiring").Cells("B2").Select
ActiveSheet.Paste
Sheets("Master").Select
Case ThisValue = "Re-Hiring "
Sheets("Master").Cells(x, 2).EntireRow.Copy
Sheets("Hiring").Select
Sheets("Hiring").Range("B2:W2500").Clear
Sheets("Hiring").Cells("B2").Select
ActiveSheet.Paste
Case ThisValue = "Termination "
Sheets("Master").Cells(x, 2).EntireRow.Copy
Sheets("Terminations").Select
Sheets("Terminations").Range("B2:W2500").Clear
Sheets("Terminations").Cells("B2").Select
ActiveSheet.Paste
Case ThisValue = "Transfer "
Sheets("Master").Cells(x, 2).EntireRow.Copy
Sheets("Transfers").Select
Sheets("Transfers").Range("B2:W2500").Clear
Sheets("Transfers").Cells("B2").Select
ActiveSheet.Paste
Case ThisValue = "Name Change "
Sheets("Master").Cells(x, 2).EntireRow.Copy
Sheets("Name Changes").Select
Sheets("Name Changes").Range("B2:W2500").Clear
Sheets("Name Changes").Cells("B2").Select
ActiveSheet.Paste
Case ThisValue = "Address Change "
Sheets("Master").Cells(x, 2).EntireRow.Copy
Sheets("Address Changes").Select
Sheets("Address Changes").Range("B2:W2500").Clear
Sheets("Address Changes").Cells("B2").Select
ActiveSheet.Paste
Case Else
Sheets("Master").Cells(x, 2).EntireRow.Copy
Sheets("New Process").Select
Sheets("New Process").Range("B2:W2500").Clear
Sheets("New Process").Cells("B2").Select
ActiveSheet.Paste
End Select
Next x
End Sub

There are a couple problems, first, you need to use the syntax Range("B2").Select to select the cell. BUT, since you selected the entire row from the master sheet, you can't copy the entire row into B2, because the ranges aren't the same size, so you need to select the first cell (A2) instead.
So, the entire case statement should look like this:
Case ThisValue = "Termination "
Sheets("Master").Cells(x, 2).EntireRow.Copy
Sheets("Terminations").Activate
Range("A2").Select
ActiveSheet.Paste

There are a number of issues
No need to Select, use variables instead
Dim all your variables - help with debugging and learning
Some general good practice techniques will help
Here's a (partially) refactored version of your code
Public Sub moveToSheet()
Dim wb As Workbook
Dim shMaster As Worksheet, shHiring As Worksheet
Dim rngMaster As Range
Dim x As Long
Dim rw As Range
Set wb = ActiveWorkbook
Set shMaster = wb.Worksheets("Master")
Set shHiring = wb.Worksheets("Hiring")
' etc
' Find the data
x = shMaster.UsedRange.Count ' trick to reset used range
Set rngMaster = shMaster.UsedRange
'Loop through each row NOTE looping thru cells is SLOW. There are faster ways
For Each rw In rngMaster.Rows
' Decide where to copy based on column F
Select Case Trim$(rw.Cells(1, 6).Value) ' Is there really a space on the end?
Case "Hiring"
shHiring.[B2:W2500].Clear
rw.Copy shHiring.[B2]
' Case ' etc
End Select
Next rw

This is what I basically use to do exactly what you are talking about. I have a "master" sheet that is several thousand rows and a couple hundred columns. This basic version only searches in Column Y and then copies rows. Because other people use this, though, I have several template worksheets that I keep very hidden so you can edit that out if you don't want to use templates. I also can add additional search variables if needed and simply adding in another couple of lines is easy enough. So if you wanted to copy rows that match two variables then you'd define another variable Dim d as Range and Set d = shtMaster.Range("A1") or whatever column you wanted to search the second variable. Then on the If line change it to If c.Value = "XXX" and d.Value = "YYY" Then . Finally make sure you add an offset for the new variable with the c.offset (so it would have a line Set d = d.Offset(1,0) at the bottom with the other). It really has turned out to be pretty flexible for me.
Sub CreateDeptReport(Extras As String)
Dim shtRpt As Excel.Worksheet, shtMaster As Excel.Worksheet
Dim LCopyToRow As Long
Dim LCopyToCol As Long
Dim arrColsToCopy
Dim c As Range, x As Integer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
On Error GoTo Err_Execute
arrColsToCopy = Array(1, 3, 4, 8, 25, 25, 21, 16, 17, 15, 31, 7) 'which columns to copy ?
Set shtMaster = ThisWorkbook.Sheets("MasterSheet")
Set c = shtMaster.Range("Y5") 'Start search in Column Y, Row 5
LCopyToRow = 10 'Start copying data to row 10 in Destination Sheet
While Len(c.Value) > 0
'If value in column Y equals defined value, copy to destination sheet
If c.Value = “XXX” Then
'only create the new sheet if any records are found
If shtRpt Is Nothing Then
'delete any existing sheet
On Error Resume Next
ThisWorkbook.Sheets("Destination").Delete
On Error GoTo 0
ThisWorkbook.Sheets("Template").Visible = xlSheetVisible
ThisWorkbook.Sheets("Template").Copy After:=shtMaster
Set shtRpt = ThisWorkbook.Sheets(shtMaster.Index + 1)
shtRpt.Name = "Destination" 'rename new sheet to Destination
‘Optional Information; can edit the next three lines out -
Range("F1").Value = "Department Name"
Range("F2").Value = "Department Head Name"
Range("B3").Value = Date
ThisWorkbook.Sheets("Template").Visible = xlSheetVeryHidden
End If
LCopyToCol = 1
shtRpt.Cells(LCopyToRow, LCopyToCol).EntireRow.Insert shift:=xlDown
For x = LBound(arrColsToCopy) To UBound(arrColsToCopy)
shtRpt.Cells(LCopyToRow, LCopyToCol).Value = _
c.EntireRow.Cells(arrColsToCopy(x)).Value
LCopyToCol = LCopyToCol + 1
Next x
LCopyToRow = LCopyToRow + 1 'next row
End If
Set c = c.Offset(1, 0)
Wend
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Range("A9").Select 'Position on cell A9
MsgBox "All matching data has been copied."
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub
Also, if you wanted then you could remove the screenupdating lines. As stupid as it sounds some people actually like to see excel working at it. With screenupdating off you don't get to see the destination sheet until the copying is completed, but with updating on the screen flickers like crazy because of it trying to refresh when each row is copied. Some of the older people in my office think that excel is broken when they can't see it happening so I keep screenupdating on most of the time. lol
Also, I like having the templates because all of my reports have quite a few formulas that need to be calculated after the information is broken down so I am able to keep all the formulas where I want them with a template. Then all I have to do is run the macro to pull from the master sheet and the report is ready to go without any further work.

Related

VBA Copy and paste entire row if cell matches list of IDs, but do not paste if list contains blank cell or cell with ""

I have what I thought would be a simple script, but I have some some strange results.
Goal: Identify specific IDs in a SOURCE sheet using a list of IDs on a Translator Sheet. When found, copy the entire row to and OUTPUT sheet.
The output has strange results that I can't figure out.
Returns all results instead of the limited list. AND results are in weird groupings. (First result is on row 21 and only has 9 rows of data, the next group has 90 rows of data, starting on row 210, then blank rows, then 900 rows of data, etc.
Results do not start in row 2.
Full code is below attempts:
Attempts:
I first searched the SOURCE sheet based on one ID that was hard coded as a simple test and it worked. but when I changed the code to search a range (z21:z), two things happened: 1, it returns everything in the Source file in multiples of 9 as stated above, AND as you can imagine, the time to complete skyrocketed from seconds to minutes. I think I missed a add'l section of code to identify the range??
Old Code:
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Worksheets("D62D627EB404207DE053D71C880A3E05") Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Output").Range("A2" & J + 1)
J = J + 1
End If
New code:
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Worksheets("Translator").Range("z21:z" & I)** Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Output").Range("A2" & J + 1)
J = J + 1
End If
1a. I believe one issue is that the Translator list has duplicates. Second, it is searching the entire column Z. Second issue may be that The list in Translator is generated via a formula in column Z, thus if the formula is false, it will insert a "" into the cell. I seek the code to NOT paste those rows where the cell content is either a "" or is a true blank cell. Reason: The "" will cause issues when we try to load the Output file into a downstream system because it is not a true blank cell.
Results in wrong location: When the script is complete, my first result does not start on Row 2 as expected. I thought the clear contents would fix this, but maybe a different clear function is required? or the clear function is in the wrong place? Below screenshot shows how it should show up. It is in the same columns but doesn't start until row 21.
enter image description here
Slow code: I have a command that copies and pastes of the first row from SOURCE to OUTPUT. My code is cumbersome. There has to be an easier way. I am doing this copy and paste just in case the source file adds new columns in the future.
Worksheets("Output").Cells.ClearContents
Sheets("SOURCE").Select
Rows("1:1").Select
Selection.Copy
Sheets("Output").Select
Rows("1:1").Select
ActiveSheet.Paste
Thank you for all your help.
Option Explicit
Sub MoveRowBasedOnCellValuefromlist()
'Updated by xxx 2023.01.18
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("SOURCE").UsedRange.Rows.Count
J = Worksheets("Output").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Output").UsedRange) = 0 Then J = 0
End If
Worksheets("Output").Cells.ClearContents
Sheets("SOURCE").Select
Rows("1:1").Select
Selection.Copy
Sheets("Output").Select
Rows("1:1").Select
ActiveSheet.Paste
Set xRg = Worksheets("SOURCE").Range("B2:B" & I)
On Error Resume Next
Application.ScreenUpdating = False
'NOTE - There are duplicates in the Translator list. I only want it to paste the first instance.
'Otherwise, I need to create an =Unique() formula and that seems like unnecessary work.
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Worksheets("Translator").Range("z21:z" & I) Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Output").Range("A2" & J + 1)
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
Try this out - using Match as a fast way to check if a value is contained in your lookup list.
Sub MoveRowBasedOnCellValuefromlist()
Dim c As Range, wsSrc As Worksheet, wsOut As Worksheet, wb As Workbook
Dim cDest As Range, wsTrans As Worksheet, rngList As Range
Set wb = ThisWorkbook 'for example
Set wsSrc = wb.Worksheets("SOURCE")
Set wsOut = wb.Worksheets("Output")
Set wsTrans = wb.Worksheets("Translator")
Set rngList = wsTrans.Range("Z21:Z" & wsTrans.Cells(Rows.Count, "Z").End(xlUp).Row)
ClearSheet wsOut
wsSrc.Rows(1).Copy wsOut.Rows(1)
Set cDest = wsOut.Range("A2") 'first paste destination
Application.ScreenUpdating = False
For Each c In wsSrc.Range("B2:B" & wsSrc.Cells(Rows.Count, "B").End(xlUp).Row).Cells
If Not IsError(Application.Match(c.Value, rngList, 0)) Then 'any match in lookup list?
c.EntireRow.Copy cDest
Set cDest = cDest.Offset(1) 'next paste row
End If
Next c
Application.ScreenUpdating = True
End Sub
'clear a worksheet
Sub ClearSheet(ws As Worksheet)
With ws.Cells
.ClearContents
.ClearFormats
End With
End Sub

How to find the differences in column A in 4 different worksheets

I have column K in "filter" sheets that need to be compare with column A in "Active_Buy", "Active_Others" and "Active_Make" sheets accordingly.
First it need to be compare with active_buy sheets. if there is value that in column K (filter sheet) but not in column A (active_Buy sheet), then it need to hold that value and compare it with column A (active_others sheets). If also didnt match, it need to compared with column A (Active_Make sheets).
So, if there is no any match, then the value need to be paste in new sheets name (Unmatched Part No).
I already search everywhere but only can find code that can only compare 2 worksheets only but not more than that.
'Below is the code that i found but only compared two worksheets only
' the concept just same like this but need to hold unmatch value and compare to next worksheet and so on.
Sub compare()
Sheets(3).Activate 'Go to sheet 3
Cells.Clear 'and clear all previous results
Range("a1").Select 'set cursor at the top
Sheets(1).Activate 'go to sheet 1
Range("a1").Select 'begin at the top
Dim search_for As String 'temp variable to hold what we need to look for
Dim cnt As Integer 'optional counter to find out how many rows we found
Do While ActiveCell.Value <> "" 'repeat the follwoing loop until it reaches a blank row
search_for = ActiveCell.Offset(0, 1).Value 'get a hold of the value in column B
Sheets(2).Activate 'go to sheet(2)
On Error Resume Next 'incase what we search for is not found, no errors will stop the macro
Range("b:b").Find(search_for).Select 'find the value in column B of sheet 2
If Err <> 0 Then 'If the value was not found, Err will not be zero
On Error GoTo 0 'clearing the error code
Sheets(1).Activate 'go back to sheet 1
r = ActiveCell.Row 'get a hold of current row index
Range(r & ":" & r).Select 'select the whole row
cnt = cnt + 1 'increment the counter
Selection.Copy 'copy current selection
Sheets(3).Activate 'go to sheet 3
ActiveCell.PasteSpecial xlPasteAll 'Past the entire row to sheet 3
ActiveCell.Offset(1, 0).Select 'go down one row to prepare for next row.
End If
Sheets(1).Activate 'return to sheet 1
ActiveCell.Offset(1, 0).Select 'go to the next row
Loop 'repeat
Sheets(3).Activate 'go to sheet 3 to examine findings
MsgBox "I have found " & cnt & " rows that did not exist in sheet 2"
End Sub
I'd use a For Each loop to run through the values on the 'Filter' sheet, set ranges on each of the other sheets, then check in each of the ranges. I've tested this code and it seems to do the trick. I've commented so you can see what's going on at each line.
(You'll need to adjust the sheet names to match you own, and adjust Application settings to make things run faster if you've got a lot of data.)
Sub compareColumns()
Dim lastRow1, lastRowAB, lastRowAO, lastRowAM, lastRowUMPN As Long
Dim rng1, rngAB, rngAO, rngAM As Range
Dim cell As Range
Dim found As Range
' Define our last rows for each sheet
lastRow1 = ThisWorkbook.Worksheets("FilterSheet").Range("K" & Rows.Count).End(xlUp).Row
lastRowAB = ThisWorkbook.Worksheets("ActiveBuy").Range("A" & Rows.Count).End(xlUp).Row
lastRowAO = ThisWorkbook.Worksheets("ActiveOthers").Range("A" & Rows.Count).End(xlUp).Row
lastRowAM = ThisWorkbook.Worksheets("ActiveMake").Range("A" & Rows.Count).End(xlUp).Row
lastRowUMPN = ThisWorkbook.Worksheets("UnmatchedPartNo").Range("A" & Rows.Count).End(xlUp).Row
' Set the ranges that we'll loop through
Set rng1 = ThisWorkbook.Worksheets("FilterSheet").Range("K1:K" & lastRow1)
Set rngAB = ThisWorkbook.Worksheets("ActiveBuy").Range("A1:A" & lastRowAB)
Set rngAO = ThisWorkbook.Worksheets("ActiveOthers").Range("A1:A" & lastRowAO)
Set rngAM = ThisWorkbook.Worksheets("ActiveMake").Range("A1:A" & lastRowAM)
' Loop through each cell in the filtered sheet
For Each cell In rng1
' Try to find the value in ActiveBuy sheet
Set found = rngAB.Find(cell.Value)
' If not found, try the next sheet
If found Is Nothing Then
Set found = rngAO.Find(cell.Value)
' If not found, try the next sheet
If found Is Nothing Then
Set found = rngAM.Find(cell.Value)
' If still not found, copy to the value to the 'Unmatched Parts' sheet
If found Is Nothing Then
ThisWorkbook.Worksheets("UnmatchedPartNo").Range("A" & lastRowUMPN + 1).Value = cell.Value
MsgBox "I have found a value " & cell.Value & " that did not exist in any sheets."
End If
End If
End If
' Reset 'found' to equal nothing for the next loop
Set found = Nothing
Next
End Sub
Here's a sub that takes 2 parameters;
A cell that has the value to search for, and a number indicating the sheet to search in.
When the sub doesn't find the value in neither of the sheets, it adds a new sheet "Unmatched Part No" if it doesn't exist and adds the value that's not found in column A in that sheet:
Sub searchSheet(ByVal searchFor As Range, sheetNum As Integer)
Dim sheetsArr As Variant
sheetsArr = Array("Active_Buy", "Active_Others", "Active_Make", "Unmatched Part No") 'You can change the names of your sheets here
If sheetNum = 3 Then 'When we reach the last sheet in our array, then we haven't find a match in neither of the previous sheets
Dim ws As Worksheet, wsExist As Boolean, lastRow As Integer
wsExist = False
'Check if the sheet "Unmatched Part No" exists
For Each ws In Worksheets
If ws.Name = sheetsArr(3) Then
wsExist = True
Exit For
End If
Next ws
'If the sheet "Unmatched Part No" doesn't exist add one with this name
If Not (wsExist) Then ThisWorkbook.Sheets.Add(after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = sheetsArr(3)
lastRow = ThisWorkbook.Sheets(sheetsArr(3)).Cells(Rows.Count, "A").End(xlUp).Row 'last used row in column A in the unmatched sheet
ThisWorkbook.Sheets(sheetsArr(3)).Range("A" & lastRow + 1).Value2 = searchFor.Value2 'append the unfound value in column A
'MsgBox "New value" & searchFor.Value2 & "appended to 'Unmatched Part No' A" & lastRow + 1
Exit Sub
End If
Dim search 'Search should be of a variant type to accept errors given by the match function
search = Application.Match(searchFor.Value2, ThisWorkbook.Sheets(sheetsArr(sheetNum)).Range("A:A"), 0)
If IsError(search) Then searchSheet searchFor, sheetNum + 1 'When match doesn't find the searchFor value, Search is an #N/A error, then search in the next sheet
End Sub
And you need another sub to call the first one passing each cell of column K of filter sheet to the first sub. Here it is:
Sub lookInSheets()
Dim lastRw As Integer, ctrlCol As Range
lastRw = ThisWorkbook.Sheets("filter").Cells(Rows.Count, "K").End(xlUp).Row 'To abbreviate the search to just the filled cells in column K
Set ctrlCol = ThisWorkbook.Sheets("filter").Range("K1:K" & lastRw)
For Each ctrlCell In ctrlCol
searchSheet ctrlCell, 0
Next ctrlCell
End Sub
Copy both subs in a new module and run the second one to achieve your goal.

Rearrange data in a column

Is there any way to automatically arrange this data
Into this
Using excel/google sheets/etc. Basically I have a huge list of files (second column) that I need to map to it's respective folder (first column ID).
What I need, is to copy column A data down, but only to the blank cells immediately below, and then do it again for the new folder id, and so on.
I happen to have a macro that prompts the user which column to copy data down. See the below (Note you may need to tweak as necessary):
Sub GEN_USE_Copy_Data_Down()
Dim screenRefresh$, runAgain$
Dim lastRow&, newLastRow&
Dim c As Range
Dim LastRowCounter$
Dim columnArray() As String
screenRefresh = MsgBox("Turn OFF screen updating while macro runs?", vbYesNo)
If screenRefresh = vbYes Then
Application.ScreenUpdating = False
Else
Application.ScreenUpdating = True
End If
Dim EffectiveDateCol As Integer
LastRowCounter = InputBox("What column has the most data (this info will be used to find the last used row")
CopyAgain:
With ActiveSheet
lastRow = .UsedRange.Rows.Count
End With
' THIS WILL ASK THE USER TO SELECT THE COLUMN TO COPY DATA DOWN
MsgBox ("Now, you will choose a column, and that column's data will be pasted in the range" & vbCrLf & "below the current cell, to the next full cell")
Dim Column2Copy As String
Column2Copy = InputBox("What columns (A,B,C, etc.) would you like to copy the data of? Use SPACES, to separate columns")
columnArray() = Split(Column2Copy)
Dim startCell As Range
For i = LBound(columnArray) To UBound(columnArray)
Debug.Print i
Column2Copy = columnArray(i)
Set startCell = Cells(1, Column2Copy).End(xlDown)
Do While startCell.row < lastRow
If startCell.End(xlDown).Offset(-1, 0).row > lastRow Then
newLastRow = lastRow
Else
newLastRow = startCell.End(xlDown).Offset(-1, 0).row
End If
Set CopyFrom = startCell
Range(Cells(startCell.row, Column2Copy), Cells(newLastRow, Column2Copy)).Value = CopyFrom.Value
Set startCell = startCell.End(xlDown)
Loop
Next i
If screenRefresh = vbYes Then
Application.ScreenUpdating = True
Else
Application.ScreenUpdating = True
End If
End Sub
I wrote it a while ago, so it might be able to have lines removed/combined, but it should work (assuming you're trying to just copy data down column A).
In Excel, select the left-hand column, HOME > Editing, Find & Select, Go to Special..., check Blanks (only), OK, then select one of the chosen cells, =, Up, Ctl+Enter.

Excel: Macro needed - 2 columns of data to become 1 column "every other"

Hello and first let me say thank you!
I use Excel to capture user requirements and descriptions. I then take that information and clean it up and paste into presentation docs, apply formatting, paste into Powerpoint, etc. It can be 100s of lines in total that this is done for. What I'm looking for is a macro that I can apply to data once it is pasted into Excel. The data will be text, non-numeric
I have a macro that I use to insert a blank row as every other row. I then do everything else manually (macro shown below).
What I'm looking for is a macro that inserts a blank row, then offsets Column 2 by 1 row down. then pastes column 1 into column 2(without copying the blank cells over my already existing data in column 2).
I've pasted a link to an image of what I'm looking for. I've also tried to show below (numbers are column 1, letters are column 2).
2 columns to 1 column - desired result
1 A 2 B3 C
Result I want:
1
A
2
B
3
C
My current "Blank Row" Macro:
Sub insertrow()
' insertrow Macro
Application.ScreenUpdating = True
Dim count As Integer
Dim X As Integer
For count = 1 To 300
If ActiveCell.Value <> "" Then
ActiveCell.Offset(1, 0).Select
Range(ActiveCell, ActiveCell.Offset(0, 0)).EntireRow.Insert
ActiveCell.Offset(1, 0).Select
For X = 1 To 1
Next X
Else
ActiveCell.Offset(1, 0).Range("a1").Select
End If
Next count
End Sub
This should work, but you'll have to adjust a little for your exact layout and needs.
Sub mergeColumns()
Dim mergedData As Variant
ReDim mergedData(1 To 600)
dataToProcess = Range("A2:B301")
For i = 1 To 300
mergedData(i * 2 - 1) = dataToProcess(i, 1)
mergedData(i * 2) = dataToProcess(i, 2)
Next i
Range("B2:B601") = WorksheetFunction.Transpose(mergedData)
End Sub
The following does what you need without inserting blank rows. It also calculates what the last row is on the sheet that has 2 columns so that you don't need to hard-code when the loop will end.
The comments should help you understand what is happening each step of the way. You can then modify this to work with your particular workbook. There are a lot of ways you could go about this. I chose to put the pivoted result on a second sheet.
Sub PivotTwoColumnsIntoOne()
Dim wb As Workbook
Dim src As Worksheet
Dim tgt As Worksheet
Dim rng As Range
Dim cell As Range
Dim lastRow As Long
Dim targetRow As Long
Set wb = ThisWorkbook
' set our source worksheet
Set src = wb.Sheets("Sheet1")
' set our target sheet (where the single column will be)
Set tgt = wb.Sheets("Sheet2")
' get the last row on our target sheet
lastRow = src.Range("A" & src.Rows.Count).End(xlUp).Row
' set the starting point for our target sheet
targetRow = 1
Set rng = src.Range("A1:A" & lastRow)
For Each cell In rng
With tgt.Range("A" & targetRow)
' get the value from the first column
.Value = cell.Value
' get the value from the second column
.Offset(1).Value = cell.Offset(, 1).Value
.HorizontalAlignment = xlLeft
End With
targetRow = targetRow + 2
Next cell
End Sub

Trying to filter a row from master sheet that doesn't get copied to individual during macro

So I have my master sheet that I run a macro on to copy a template and then populate with certain rows based off of values in one column. I need to add a check in so that I can tell it not to pull the row if the value in another column matches a specified criteria. For example, row x would get pulled if the value in column Y matches 1234, but only if the value in column Z does not match 456. This is the code I am using right now:
Option Explicit
Sub Report()
CreateDeptReport "Report"
End Sub
Sub CreateDeptReport(Report As String)
Dim shtRpt As Excel.Worksheet, shtMaster As Excel.Worksheet
Dim LCopyToRow As Long
Dim LCopyToCol As Long
Dim arrColsToCopy
Dim c As Range, X As Integer
On Error GoTo Err_Execute
arrColsToCopy = Array(1, 3, 4, 8, 25, 16, 17, 15, 31, 7, 26) 'which columns to copy ?
Set shtMaster = ThisWorkbook.Sheets("RawData")
Set c = shtMaster.Range("Y5") 'Start search in Row 5
LCopyToRow = 10 'Start copying data to row 10 in Mental
While Len(c.Value) > 0
'If value in column Y ends with "2135", copy to report sheet
If c.Value Like "*2135" Then
'only create the new sheet if any records are found
If shtRpt Is Nothing Then
'delete any existing sheet
On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Sheets("NewSheetName").Delete
Application.DisplayAlerts = True
On Error GoTo 0
ThisWorkbook.Sheets("Template").Copy After:=shtMaster
Set shtRpt = ThisWorkbook.Sheets(shtMaster.Index + 1)
shtRpt.Name = "NewSheetName" 'rename new sheet to NewSheetName
Range("F1").Value = "XXXX"
Range("F2").Value = "XXXX"
Range("B3").Value = Date
Range("B4").Value = "XXXX"
End If
LCopyToCol = 1
shtRpt.Cells(LCopyToRow, LCopyToCol).EntireRow.Insert shift:=xlDown
For X = LBound(arrColsToCopy) To UBound(arrColsToCopy)
shtRpt.Cells(LCopyToRow, LCopyToCol).Value = _
c.EntireRow.Cells(arrColsToCopy(X)).Value
LCopyToCol = LCopyToCol + 1
Next X
LCopyToRow = LCopyToRow + 1 'next row
End If
Set c = c.Offset(1, 0)
Wend
ThisWorkbook.Worksheets("NewSheetName").Rows("9:9").Delete
Range("A9").Select 'Position on cell A9
MsgBox "All matching data has been copied."
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub
This is what I've got; I'd like to do as little restructuring as possible since I know this does exactly what I want save this one stupid wrinkle. I've tried adding in conditions around the c.Value line but I'm not getting anywhere. Thanks for any advice!
Your first criteria range is labelled "c" so let's called your second one "d". Add in these lines in the appropriate places:
Right after all your other Dim statements, add
Dim d as range
After the set c line, add
Set d = shtMaster.Range("Y5")
Change
If c.Value Like "*2135" Then to
If c.Value Like "*2135" and d.Value not like "*456*" Then
Right before Wend add
Set d = d.Offset(1, 0)
I might have missed a line or two, but basically I'm trying to keep the same logic pattern and duplicate the lines that changed your c variable. (If I missed a line or two, please point them out in the comments)

Resources