I have a workbook with 4 worksheets and Sheet4 (titled "Deficiency List") is populated in 'column B' with values from other sheets based on different criteria. The list begins with "B1" and goes to "B1155". I would like to only copy the cells that have data in them and not the blanks to Sheet3 (titled "Deficiencies") starting at cell "B12".
Example, if there is only data on Sheet4 in cells: B3, B36, B756 and B1005, those would be copied to Sheet3 into cells: B12, B13, B14 and B15.
Here is the code I have to copy the data but it doesn't eliminate the blanks.
Sub Copy_Values()
Dim i As Long
Sheets("Deficiency List").Select
iMaxRow = 1155
For iRow = 1 To iMaxRow
With Worksheets("Deficiency List").Cells(iRow, 2)
' Check that cell is not empty.
If .Value = "" Then
'Nothing in this cell.
'Do nothing.
Else
' Copy the cell to the destination
Worksheets("Deficiencies").Cells(iRow + 11, 2).Value = .Value
End If
End With
Next iRow
End Sub
If (Trim$(CStr(.Value)) = "") Then
If you don't want rows in output area to be skipped,
declare a Long variable to hold destination row number
initialize it outside the loop to 11
in the else part, increment the variable and then use it as row number instead of irow + 11
Sub Copy_Values()
Dim i As Long, d As Long, shtD, shtDL, tmp
Dim iMaxRow As Long, iRow As Long
Set shtD = Worksheets("Deficiencies")
Set shtDL = Worksheets("Deficiency List")
iMaxRow = 1155
d = 12
For iRow = 1 To iMaxRow
With shtDL.Cells(iRow, 2)
tmp = Trim(.Value)
If Len(tmp) > 0 Then
shtD.Cells(d, 2).Value = tmp
d = d + 1
End If
End With
Next iRow
End Sub
Related
I have 2 sheets. Sheet1 has 2 rows: column names and values.
Sheet 2 is a master sheet with all the possible column names in. I need to copy the values from sheet 1 into their appropriate column.
I think i can do this via a match function, and so far i have this:
Sub dynamic_paste()
Dim Columnname As String
Dim inputvalue As String
Dim starter As Integer
Dim i As Integer
starter = 0
For i = 1 To 4
'replace 4 with rangeused.rows.count?
Sheets("sheet1").Select
Range("a1").Select
ActiveCell.Offset(0, starter).Select
Columnname = ActiveCell
'sets columnname variable
ActiveCell.Offset(1, 0).Select
inputvalue = ActiveCell
'sets inputname variable
Sheets("sheet2").Select
'**Cells(0, WorksheetFunction.Match(Columnname, Rows(1), 0)).Select**
Range("a1").Offset(1, starter).Value = inputvalue
'inputs variable in the next cell along
starter = starter + 1
Next
End Sub
I need to find out how to use my columnname variable as the matching value, and then offset down to the first row that is empty - then change the value of that cell to the variable called inputvalue.
For extra points: I need to make sure the code doesnt break if they dont find a matching value, and if possible put any values that dont match into the end of the row?
What about this:
Dim LR As Long, X As Long, LC As Long, COL As Long
Dim RNG As Range, CL As Range
Option Explicit
Sub Test()
LR = Sheets(2).Cells.SpecialCells(xlCellTypeLastCell).Row 'Get last used row in your sheet
LC = Sheets(2).Cells(1, Sheets(2).Columns.Count).End(xlToLeft).Column 'Get last used column in your sheet
Set RNG = Sheets(2).Range(Sheets(2).Cells(1, 1), Sheets(2).Cells(1, LC))
'Loop through all the columns on your sheet with values
For X = 1 To Sheets(1).Cells(1, Sheets(1).Columns.Count).End(xlToLeft).Column
Set CL = RNG.Find(Sheets(1).Cells(1, X).Value, lookat:=xlWhole)
If Not CL Is Nothing Then
COL = CL.Column
Sheets(2).Cells(LR + 1, COL).Value = Sheets(1).Cells(2, X).Value 'Get the value on LR offset by 1
Else
Sheets(2).Cells(1, Sheets(2).Cells(1, Sheets(2).Columns.Count).End(xlToLeft).Column).Value = Sheets(1).Cells(1, X).Value
Sheets(2).Cells(LR + 1, Sheets(2).Cells(1, Sheets(2).Columns.Count).End(xlToLeft).Column).Value = Sheets(1).Cells(2, X).Value
End If
Next X
End Sub
This way you will avoid using select. Which is very recommandable!
This is Sheet1:
This is Sheet2:
This is the code:
Option Explicit
Sub DynamicPaste()
Dim col As Long
Dim wks1 As Worksheet: Set wks1 = Worksheets(1)
Dim wks2 As Worksheet: Set wks2 = Worksheets(2)
For col = 1 To 3
Dim currentRow As Long
currentRow = WorksheetFunction.Match(wks2.Cells(1, col), wks1.Columns(1))
wks2.Cells(2, col) = wks1.Cells(currentRow, 2)
Next col
End Sub
This is Sheet2 after the code:
This is a must-read - How to avoid using Select in Excel VBA
I am writing the Sheet names and assigning progress in front of it (adjacent cell) from that sheet.
Suppose sheet name is sheet1, sheet2 ...
I am trying to write
Sheet1 B50 of sheet1
Sheet2 B50 ofsheet2
Sub LoadSummarySheet()
Dim row, i, col As Integer
row = 5
col = 3
Range("C5:C15").ClearContents
For i = 1 To Sheets.Count
If Application.Sheets(i).Name <> "TRACKER" And Application.Sheets(i).Name <> "Sheet1" And Application.Sheets(i).Name <> "PROGRESS" Then
Cells(row, col).Value = Application.Sheets(i).Name
row = row + 1
Range(Cells(row, col + 1)).Value = Application.Sheets(i).Range("B50").Value
End If
Next
maybe you're after something like this (explanations in comments)
Sub LoadSummarySheet()
Dim row As Long, col As Long
row = 5
col = 3
Range("C5:C15").ClearContents
Dim forbiddenNames As String
forbiddenNames = "TRACKER,Sheet1,Sheet2,PROGRESS" 'list sheet names you don't want to be processed
Dim sht As Worksheet
For Each sht In Worksheets 'loop through currently active workbook sheets
If InStr(forbiddenNames, sht.Name) = 0 Then 'if current sheet name is not "forbidden"
Cells(row, col).Value = sht.Name
row = row + 1
Cells(row, col + 1).Value = sht.Range("B50").Value
End If
Next
End Sub
all this assumes that the macro is being run when Summary Sheet is the active one
if this can be not the case then you can assure to write in the proper sheet as follows:
Sub LoadSummarySheet()
Dim row As Long, col As Long
row = 5
col = 3
Range("C5:C15").ClearContents
Dim forbiddenNames As String
forbiddenNames = "TRACKER,Sheet1,Sheet2,PROGRESS" 'list sheet names you don't want to be processed
Dim sht As Worksheet
With Worksheets("TRACKER") ' reference wanted "summary" sheet (change TRACKER" to your actually "summary" sheet name)
For Each sht In Worksheets 'loop through currently active workbook sheets
If InStr(forbiddenNames, sht.Name) = 0 Then 'if current sheet name is not "forbidden"
.Cells(row, col).Value = sht.Name ' preface a dot (.) to reference referenced object (i.e. 'Worksheets("TRACKER")' in this case)
row = row + 1
.Cells(row, col + 1).Value = sht.Range("B50").Value ' preface a dot (.)
End If
Next
End With
End Sub
I have a workbook that has 4 worksheets all of which have dates on row 5, stating at column D. In the cell next to the date the person will put either 'ET','LT','EG','1ET', '2LT' or they will leave it blank.
I am reading on how VBA works at the moment but I have just started so very new to this.
I have this so far:
Sub test()
Dim summarySheet As Worksheet
Dim sh As Worksheet
Dim j As Integer
'change "Summary" to the sheet name that is true for you'
Set summarySheet = ThisWorkbook.Worksheets("Summary")
'number of first row where need to paste in summary sheet'
j = 2
'loop throught all sheets'
For Each sh In ThisWorkbook.Worksheets
If sh.Name <> summarySheet.Name Then
summarySheet.Range("B" & j & ":AF" & j).Value = _
sh.Range("D5:AH5").Value
j = j + 1
End If
Next
End Sub
It displays all the sheets data, but what I need is if there is either ET or LT entered in row 5 next to the date then it adds the corresponding data from row 37 into a summary sheet. If it's just the number then it is to skip that and find the next ET or LT
EG
Sheet 1
Row 5 1ET 2LT 3ET 4 5 6 7ET 8ET
===========================
Row 37 16 32 2 45 67
Sheet 2
Row 5 1 2 3LT 4ET 5ET 6LT 7 8LT
===========================
Row 37 23 33 13 22 34
SUMMARY SHEET
ET LT
1 16
2 32
3 2 23
4 33
5 13
6
7 45
8 67 34
9
Etc
I don't completely understand what you are trying to do. Your code copies the range exactly to the Summary sheet, but it looks like the result you want transposes them - has the numbers/dates running down the rows instead of across the rows. Also, you say "dates" but have the numbers 1-9 on the Summary Sheet and have the numbers 1-9 on your Sheet1 and Sheet2. I also cannot tell which column the "corresponding" values in row 37 are.
Therefore, this code may not exactly work for you as it based on the assumptions that 1) you do NOT want D5:AH5 from each sheet pasted exactly onto the Summary sheet; 2) since they are the only ones you mention as criteria, "ET" and "LT" are the only codes next to "dates" you care about; 3) the value in row 37 is in the same column as the "date"; 4) the "1ET" and "2LT" in your data represent a "1" in D5, "ET" in E5, "2" in F5, "LT" in G5, and so on; 5) since you used the numbers 1-9, the row for pasting the value from row 37 is determined by taking the "date" and adding 1. If you have actual dates, you will need to change your logic for pasteRow.
Sub test()
Dim summarySheet As Worksheet
Dim sh As Worksheet
Dim searchRng As Range
Dim dateCell As Range
Dim pasteCol As Integer
Dim copyRow As Integer
Dim pasteRow as integer
'change "Summary" to the sheet name that is true for you'
Set summarySheet = ThisWorkbook.Worksheets("Summary")
'the "corresponding row" to copy
copyRow = 37
'loop throught all sheets'
For Each sh In ThisWorkbook.Worksheets
If sh.Name <> summarySheet.Name Then
'set the range that we are using
Set searchRng = sh.Range("D5:AH5")
For Each cell In searchRng
'loop through the range and check if it has the desired key value
If cell.Value = "ET" Or cell.Value = "LT" Then
'set which column on SummarySheet will get the value
If cell.Value = "ET" Then
'column B, ie column #2
pasteCol = 2
ElseIf cell.Value = "LT" Then
'column C, ie column #3
pasteCol = 3
End If
'set the cell containing the date - assumes is to the left of our key value cell
Set dateCell = cell.Offset(0, -1)
'set row # to paste to, ie if the value in dateCell is 9, then paste to row 10
pasteRow = dateCell.Value + 1
'set the value on summarySheet using the value in dateCell + 1 for our row number
'and dateCell's column with copyRow to get our "corresponding" value
summarySheet.Range(Cells(pasteRow, pasteCol).Address).Value = _
sh.Range(Cells(copyRow, dateCell.Column).Address)
End If
Next cell
End If
Next
End Sub
EDITED based on new information from actual spreadsheet:
Sub test()
Dim summarySheet As Worksheet
Dim sh As Worksheet
Dim searchRng As Range
Dim dateNum As Integer
Dim pasteCol As Integer
Dim copyRow As Integer
Dim pasteRow As Integer
Dim c As Range
Dim oldVal As Integer
'change "Summary" to the sheet name that is true for you'
Set summarySheet = ThisWorkbook.Worksheets("Summary")
'clear current value on summarySheet
summarySheet.Range("C3:D33").Value = ""
'loop throught all sheets'
For Each sh In ThisWorkbook.Worksheets
If sh.Name <> summarySheet.Name Then
'set the range that we are using
Set searchRng = sh.Range("D5:AH5")
'the "corresponding row" to copy
With sh.Range("C:C")
Set c = .Find("Number of staff")
If Not c Is Nothing Then
copyRow = c.Row
End If
End With
For Each cell In searchRng
'loop through the range and check if it has the desired key value
If cell.Value Like "*ET" Or cell.Value Like "*LT" Then
'set which column on SummarySheet will get the value
If cell.Value Like "*ET" Then
'column C, so column #3
pasteCol = 3
ElseIf cell.Value Like "*LT" Then
'column D, so column #4
pasteCol = 4
End If
'get the date from the cell
dateNum = Val(cell.Value)
If dateNum = 0 Then
MsgBox "Sheet " & sh.Name & " cell " & cell.Address & " is missing date. Please fill in and run again."
Exit Sub
End If
'set row # to paste to, ie if the value in dateCell is 9, then paste to row 11
pasteRow = dateNum + 2
'set the value on summarySheet using cell's column with copyRow to get our "corresponding" value
oldVal = summarySheet.Range(Cells(pasteRow, pasteCol).Address).Value
summarySheet.Range(Cells(pasteRow, pasteCol).Address).Value = _
sh.Range(Cells(copyRow, cell.Column).Address).Value + oldVal
End If
Next cell
End If
Next
MsgBox "Complete"
End Sub
Option Explicit
Private Sub Worksheet_Activate()
Dim r As Range, rng As Range, snRow As Range, x As Integer
ActiveSheet.Range("C4:AG5").ClearContents
For x = 1 To Sheets.Count
If Sheets(x).Name <> "Summary" Then
With Sheets(Sheets(x).Name)
With .Range("C:C")
Set snRow = .Find("Number of staff", LookIn:=xlValues, lookat:=xlWhole)
End With
Set rng = .Range("D5", "AH5")
For Each r In rng
If InStr(1, r.Value, "LT") > 0 Then
Sheets("Summary").Cells(5, r.Column - 1) = .Cells(snRow.Row, r.Column).Value
ElseIf InStr(1, r.Value, "ET") > 0 Then
Sheets("Summary").Cells(4, r.Column - 1) = .Cells(snRow.Row, r.Column).Value
End If
Next
End With
End If
Next
End Sub
This achieves everything I wanted with the summary sheet going across the page instead of vertically.
I have a spreadsheet that list a Case Manager and then list the students below it. Then it lists another Case Manager and students below it. I want to copy the Case Manager Name from the top of each list to the end of the row of respective students underneath, repeating with each Case Manager until I get to the end of my sheet. The number of Case Managers and students can vary.
I have the following code to do the first Case Manager but not sure how to loop it of if there is a better solution. I want all the data to stay in the original spot.
Original Source: (Imported Text File)
Modified Source: (After Macro is Run)
Sub CMWizard()
Dim CMName As String
Dim StopRow As Long
Dim r As Long
CMName = Range("A1").Value 'Get the Case Manager Name.
StopRow = Range("B2").End(xlDown).Row 'Get first blank cell in Column B.
For r = 2 To StopRow 'Start at Row 2 and continue until you reach the StopRow.
Cells(r, 6).Value = CMName 'Set every cell from Row 2 in Column F (6) to the Case Manager Name.
End Sub
Let's say your Excel file looks like this
Paste this code in a module. I have commented the code so that you will not have a problem understanding it.
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim i As Long, LRow As Long, R As Long
Dim CM As String
Dim delRng As Range
Application.ScreenUpdating = False
'~~> Replace Sheet 1 with the relevant sheet name
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Get last row of Col A
LRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Loop through cells in Col A
For i = 1 To LRow
'~~> Check if the cell contains "Case Manager"
If InStr(1, .Cells(i, 1).Value, "Case Manager", vbTextCompare) Then
'~~> Store the Case manager's name in a variable
CM = .Cells(i, 1).Value
'~~> Store the row numbers which have "Case Manager"
'~~> We will delete it later
If delRng Is Nothing Then
Set delRng = .Rows(i)
Else
Set delRng = Union(delRng, .Rows(i))
End If
Else
'~~> Store the Case manager in Col F
.Cells(i, 6).Value = CM
End If
Next i
End With
'~~> Delete the rows which have "Case Manager"
If Not delRng Is Nothing Then delRng.Delete
Application.ScreenUpdating = True
End Sub
Output
i think you are just missing an next
Sub CMWizard()
Dim CMName As String
Dim StopRow As Long
Dim r As Long
CMName = Range("A1").Value 'Get the Case Manager Name.
StopRow = Range("B2").End(xlDown).Row 'Get first blank cell in Column B.
For r = 2 To StopRow 'Start at Row 2 and continue until you reach the StopRow.
Cells(r, 6).Value = CMName 'Set every cell from Row 2 in Column F (6) to the Case Manager Name.
Next
End Sub
just be aware that StopRow = Range("B2").End(xlDown).Row will return last row in worksheet if there are just empty cells below ("B2")
Hope it helps
Below are my codes, I am trying to force the checking to start from the first cell, but it doesn't work. Can anyone advise me on that. Thanks
I am trying to do checking on the names which is on the 3rd column of Workbook A and compare it with the other column in another workbook. Upon match of the string, it will copy certain cells to the desalinated column
Sub copyandpaste()
Set From_WS = Workbooks("copy_data2").Worksheets("Data")
Set To_WS = Workbooks("Book1").Worksheets("Sheet1")
Dim v1 As String
Dim v2 As String
Dim diffRow As Long
Dim dataWs As Worksheet
Dim copyWs As Worksheet
Dim rowData As Long
Dim totRows As Long
Dim lastRow As Long
Dim result As String
Dim row_no As Integer
Dim Name As Range
Dim Namelist As Range
diffRow = 1 'compare
Set dataWs = Worksheets("Data")
Set copyWs = Worksheets("Diff")
For Each c In Worksheets("Data").Range("C2:C10")
If c.Value <> "" Then
v1 = c
End If
For Each d In Workbooks("Book1").Worksheets("Sheet1").Range("B2:B10")
If d.Value <> "" Then
v2 = d
End If
With From_WS.Cells(1, 2).CurrentRegion
Total_Rows = .Rows.Count
Total_Columns = .Columns.Count
End With
Set mycellA = From_WS.Range("C:C")
Set mycellB = To_WS.Range("B:B")
Copy = False
' With Sheets("copy_data2")
' lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
'find first row
'column1 = Range("A2").End(xlToRight).Column
'For row_no = 1 To 10
'=========================================================================
Set Namelist = dataWs.Range("A1:A" & dataWs.Cells(Rows.Count, "A").End(xlUp).Row)
'Now loop through all the cells in the range
'For Each Name In Namelist.Cells
mynumber = 1
For Each Name In Namelist
'=======================================================================
If v1 = v2 Then
'select sheet
Sheets("Data").Select
'ActiveCell.Select 'select active cell
ActiveCell.Interior.ColorIndex = 36 'color the cell
'copy active cell same row
ActiveCell.Range("A1:F1").Copy
ActiveCell.Interior.ColorIndex = 50 'color the cell
'Paste file destination
Sheets("Diff").Select
Sheets("Diff").Range("A2").Select
'Paste Active
ActiveSheet.Paste
ActiveCell.Interior.ColorIndex = 37 '<< Colored Blue
'==================================================================
'select sheet
Sheets("Data").Select
'ActiveCell.Select 'select active cell
ActiveCell.Interior.ColorIndex = 36 'color cell Yellow
'result = ActiveCell.EntireRow.copy
'copy active cell same row
ActiveCell.Range("H1:J1").Copy
'Paste file destination
Sheets("Diff").Select
'Paste cell destination
Sheets("Diff").Range("G2").Select
'Paste Active
ActiveSheet.Paste
mynumber = mynumber + 1
End If
Next Name
Next d
Next c
End Sub
This is the second function, to count and go through the rows.
Sub RoundToZero1()
For Counter = 1 To 20
Set curCell = Worksheets("Data").Cells(Counter, 3)
If Abs(curCell.Value) < 0.01 Then curCell.Value = 0
Next Counter
End Sub
Update Question:
I have the code below, I need to make the column A to be incremental. Anyone have suggestion how to achieve that?
Sheets("Diff").Range("A").Select
The line Set selectedCell = selectedCell + 1 throws an error when I run it and doesn't appear to do anything in the code, if that is the case you should comment it out or delete it.
Also I think you need to change
Else
If IsEmpty(Cells(i, 1)) = True Then 'if cells in column "A" is empty then stop
to
ElseIf IsEmpty(Cells(i, 1)) = True Then 'if cells in column "A" is empty then stop
As it stands you have an extra open If statement.