I want to find empty cells and copy there values:
Values: "10/11/2017" and "Yes" should be copied to row 7 (colB & colC).
What I have:
Sub add_value()
Dim wbA As Workbook
Dim wsA As Worksheet
Set wbA = ActiveWorkbook
Set wsA = wbA.Worksheets("Sheet1")
Dim nrow As Long
nrow = 6
Do Until wsA.Range("B" & nrow).Value = ""
wsA.Range("B" & nrow).Value = wsA.Range("B3").Value
wsA.Range("C" & nrow).Value = wsA.Range("C3").Value
Exit Sub
nrow = nrow + 1
Loop
End Sub
Something is wrong with my loop and I don't know how to fix it.
No need to loop through your rows until you find an empty one. You can replace the entire sub with this:
Sub add_value()
With ThisWorkbook.Worksheets("Sheet1")
.Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0).Resize(1, 2).Value = .Range("B3:C3").Value
End With
End Sub
As per your comments, to also add borders you can reorganise the code a bit like this:
Sub add_value()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
With ws.Cells(ws.Rows.Count, "B").End(xlUp).Offset(1, 0).Resize(1, 2)
.Value = ws.Range("B3:C3").Value
.Borders(xlEdgeLeft).LineStyle = xlContinuous
End With
End Sub
I would have done something like this:
Sub FindFirstEmptyValue()
Dim lastRow As Long
With Worksheets("Sheet1")
lastRow = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
.Cells(lastRow, 2) = .Range("B3").value
.Cells(lastRow, 3) = .Range("C3").value
End With
End Sub
It gives you the last row, you increment it with 1 and on this row you write the B3 and C3 values.
Related
Fairly new to VBA Excel. I want to copy and paste a specific cell[B11 and so on) into a specific cell [E9 and so on] on my target sheet when conditions are met (when C column is equal to No). So far I was able to copy and paste the data on my target sheet. Having trouble when I run the command again. I don't want to overwrite my previous data. How can this be done? `
Private Sub CommandButton1_Click()
Dim RowGCnt As Long, CShtRow As Long
Dim LastRow As Long
Dim CellG As Range
'paste the first result to the 9th row
CShtRow = 9
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For RowGCnt = 11 To LastRow
If Range("C" & RowGCnt).Value = "No" Then
MsgBox (CShtRow)
'Review Criteria
Worksheets("SHEET1").Range("B" & RowGCnt).Copy
Worksheets("REPORT").Range("E" & CShtRow).PasteSpecial xlPasteValues
CShtRow = CShtRow + 1
End If
Next RowGCnt
Application.CutCopyMode = False
End Sub
Untested:
Private Sub CommandButton1_Click()
Dim shtSrc As Worksheet '<< source sheet
Dim RowGCnt As Long
Dim LastRow As Long
Dim cDest As Range '<< copy destination
Set shtSrc = Worksheets("SHEET1")
'paste the first result to the first open row
With Worksheets("REPORT")
Set cDest = .Cells(.Rows.Count, "E").End(xlUp).Offset(1, 0) '<<EDIT
If cDest.Row < 9 Then Set cDest = .Range("E9")
End With
LastRow = shtSrc.Range("A" & shtSrc.Rows.Count).End(xlUp).Row
For RowGCnt = 11 To LastRow
If shtSrc.Range("C" & RowGCnt).Value = "No" Then
cDest.Value = shtSrc.Range("B" & RowGCnt).Value
Set cDest = cDest.Offset(1, 0)
End If
Next RowGCnt
End Sub
Using Tim Williams code. I got a workaround
Private Sub CommandButton1_Click()
Dim shtSrc As Worksheet '<< source sheet
Dim RowGCnt As Long
Dim LastRow As Long
Dim cDest As Range '<< copy destination
Dim vLastRow As Integer
Set shtSrc = Worksheets("SHEET1")
'paste the first result to the first open row
With Worksheets("REPORT")
Set cDest = .Cells(.Rows.Count, "E").End(xlUp)
If cDest.Row < 9 Then
Set cDest = .Range("E9")
Else
vLastRow = .Cells(.Rows.Count, 5).End(xlUp).Row
Set cDest = .Cells(vLastRow + 1, 5)
End If
End With
LastRow = shtSrc.Range("A" & shtSrc.Rows.Count).End(xlUp).Row
For RowGCnt = 11 To LastRow
If shtSrc.Range("C" & RowGCnt).Value = "No" Then
cDest.Value = shtSrc.Range("B" & RowGCnt).Value
Set cDest = cDest.Offset(1, 0)
End If
Next RowGCnt
End Sub
I got stuck in the below-mentioned code, what I want to do is to get the value from Range("C4:C" & LastRow) in worksheets X2 that will b changing every time and compare each value with all open workbooks name. If match found then search that value in A column of worksheet X1 and copy all those rows.
The final objective is to paste those rows into those open workbooks which have the same value. For eg: Range C4 has TW00 then the code will search workbooks which have name "TW00.xlsx" and copy all the rows from worksheet X1 which have TW00 value in column A in the worksheet named TW00.xlsx.
Dim BookNames()
ReDim BookNames(Windows.Count)
n = 1
For n = 1 To Windows.Count
BookNames(n) = Workbooks(n).Name
If Workbooks(n).Name = Workbooks("A.xlsx").Worksheets("X2").Range("C4:C" & LastRow).Value Then
Set Rng = Workbooks("A.xlsx").Worksheets("X1").Range("A2:A50000")
For Each c In Rng.Cells
If c.Value = Workbooks("A.xlsx").Worksheets("X2").Range("C4").Value Then
If Not CopyRng Is Nothing Then
Set CopyRng = Application.Union(CopyRng,
Workbooks("A.xlsx").Worksheets("X1").Rows(c))
Else
Set CopyRng = Workbooks("A.xlsx").Worksheets("X1").Rows(c)
End If
End If
Next c
CopyRng.Copy
Workbooks(n).Activate
Worksheets.Add
ActiveSheet.Name = "X1"
ActiveSheet.Paste
End If
Next n
is that code help you?
Sub test()
Dim lastRow As Long
dim sheetName as string
Dim sourceDataSheet As worksheet
Dim sourceSheetsName as worksheet
dim targetDataSheet as worksheet
Dim wkb As Variant
set sourceDataSheet = ActiveWorkbook.Worksheets("X2")
set sourceSheetsName = ActiveWorkbook.Worksheets("X1")
With sourceSheetsName
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
sheetName = .Cells(lastRow, "A")
For Each wkb In Application.Workbooks
If wkb.Name <> .Name And wkb.Name = sheetName Then
set targetDataSheet = wkb.Worksheets.Add
with sourceDataSheet
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
for i = 1 to lastRow
if .Cells(i, "A").Value = sheetName then
.Cells(i, "A").EntireRow.Copy
targetDataSheet.Cells(i, "A").PasteSpecial Paste:=xlPasteValues
end if
next i
end with
End If
Next wkb
End With
End Sub
I don't know why I am having the hardest time with this. I am just trying to copy a single row from sheet1 to the next available row on sheet2. I have to row copied but it just wont paste without giving me error. This is my copy and it is working.
ws1.Rows(j).EntireRow.Copy
Following should be helpful
Sub Demo()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lastRow As Long, j As Long
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
For j = 1 To 10 'change loop as required
If (your_condition) Then
lastRow = lastRow + 1
ws1.Rows(j).EntireRow.Copy ws2.Range("A" & lastRow)
End If
Next j
End Sub
Try this:
Code Sample:
Sheets("Sheet1").Cells(i, "A").EntireRow.Copy Destination:=Sheets("Sheet 2").Range("A" & Rows.Count).End(xlUp).Offset(1)
You may use the below code
Sub CopyPaste()
Sheet1.Range("A:A").Copy
Sheet2.Activate
col = 1
Do Until Sheet2.Cells(1, col) = ""
col = col + 1
Loop
Sheet2.Cells(1, col).PasteSpecial xlPasteValues
End Sub
I have the below code. The code will go into each of the 17 workbooks and extract certain columns based on the columns headers name. This will repeat and add to the bottom of the master workbook, until the last one has been extracted.
Unfortunately, if there is nothing in one of the columns on one of the individual 17 workbooks, the data from the next workbook gets moved up in the cells. Is there anyway to sort this. I have added the code below.
Option Explicit
Sub CopyColumns()
Dim CopyFromPath As String, FileName As String
Dim CopyToWb As Workbook, wb As Workbook, CopyToWs As Worksheet
Dim lastRow As Long, NextRow As Long, lcol As Long, c As Long, sv As Integer
Dim ws As Worksheet
Dim myCol As Long
Dim myHeader As Range
r\"
Set CopyToWb = ActiveWorkbook
Set c).End(xlUp).Row
If lastRow = 1 Then GoTo nxt
Range(Cells(2, c), Cells(lastRow, c)).Copy
CopyToWs.Activate
Set myHeader = CopyToWs.Rows(1).Find(What:=.Cells(1, c).Value, Lookat:=xlWhole)
With CopyToWs
If Not myHeader Is Nothing Then
myCol = myHeader.Column
NextRow = .Cells(Rows.Count, myCol).End(xlUp).Row + 1
.Cells(NextRow, myCol).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Set myHeader = Nothing
End If
nxt:
End With
End If
Next c
wb.Close saveChanges:=False
End With
FileName = Dir
Loop
Application.ScreenUpdating = True
End Sub
Thank you in advance
Calculate NextRow only once per workbook, and then use it for all columns:
Do While Len(FileName) > 0
'Calculate the next row to be populated for all columns, based on the last
'used cell in column A
'(I used column A, but pick whatever destination column will always be
'populated in every workbook.)
With CopyToWs
NextRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
'Process this workbook
Set wb = Workbooks.Open(CopyFromPath & FileName)
With wb.Sheets("Open Issue Actions")
lcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
For c = 1 To lcol
'...
With CopyToWs
If Not myHeader Is Nothing Then
myCol = myHeader.Column
'NextRow = .Cells(Rows.Count, myCol).End(xlUp).Row + 1
.Cells(NextRow, myCol).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Set myHeader = Nothing
End If
End With
nxt:
'...
Actually you want one row per sheet. Nothing else. Nothing more. You do not even need to calculate it. You need to increment it lngRow = lngRow+1.
Try to use the following into your code:
Option Explicit
Sub CopyColumns()
Dim lngRow As Long: lngRow = 1
Do While Len(FileName) > 0
Set wb = Workbooks.Open(CopyFromPath & FileName)
With wb.Sheets("Open Issue Actions")
lngRow = lngRow + 1
With CopyToWs
If Not myHeader Is Nothing Then
myCol = myHeader.Column
.Cells(lngRow, myCol).PasteSpecial xlPasteValues
Set myHeader = Nothing
End If
End With
End With
wb.Close saveChanges:=False
Loop
Application.ScreenUpdating = True
End Sub
In the code you add/edit three things:
The line Dim lngRow as Long: lngRow=1 on top with the other Dim
lngRow = lngRow + 1 after the With wb.Sheets("Open Issue Actions")
the paste values should be like this .Cells(lngRow, myCol).PasteSpecial xlPasteValues
The whole code is here: https://pastebin.com/kXdzkGZ1
The idea is to have lngRow and to increment it for every WorkSheet that you open. And do not do anything else with it.
In general, your code can be optimized in some ways, if it works ok after the change, put it here for further ideas: https://codereview.stackexchange.com/
I have been a silent reader on here for a few months but have been struggling with this code for a week now, so thought i would see if anyone can help.
I have a worksheet where sheet 1 contains information for users to input data.
Column A ask a question, column C is where the user will type in an answer.
Row 4 asks how many configurations there will be. depending on what number they input depends on how many cells light up to the right ie if 1 then D4 goes yellow, if 2 then D4 and E4 go yellow (using conditional formatting)
The user will then enter the title into the highlighted cell (D4,E4 ,F4 etc)
I want to create a new sheet at the end of the sheet for each configuration.
then NAME the new sheet by the text entered in D4, E4 etc.
the code I have so far is:
Option Explicit
Sub InsertSupplierSheet()
Dim ws As Worksheet
Dim tmpSht As Worksheet
Dim Lastcol As Integer, i As Integer, j As Integer
Dim DESCRANGE As Range
'~~> Change Sheet1 to the sheet which has all the data
Set ws = ThisWorkbook.Worksheets(1)
With ws
Lastcol = ActiveSheet.Cells(4, Columns.Count).End(xlToLeft).Column
If Lastcol < 4 Then Exit Sub
For i = 3 To Lastcol
If DoesSheetExist(ActiveSheet.Cells(4 & i).Value) Then
Set tmpSht = ActiveSheet.Cells(4 & i).Value
Else
Sheets.Add After:=Sheets(Sheets.Count)
Set tmpSht = ActiveSheet
tmpSht.Name = "NEWSHEET"
End If
.Rows("1:3").Copy tmpSht.Rows(1)
For j = 1 To 4
tmpSht.Columns(j).ColumnWidth = .Columns(j).ColumnWidth
Next j
.Rows(i).Copy tmpSht.Rows(4)
Next
End With
End Sub
Function DoesSheetExist(Sht As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Sheets(ws)
On Error GoTo 0
If Not ws Is Nothing Then DoesSheetExist = True
End Function
I put in "NEWSHEET" to see if even creates a new sheet, but it still fails. I just cant see where I am going wrong.
Any help /advise is welcomed.
EDIT .
I cant work out why though.
The last col will be H4 so lastcol would be "8" .
Then for i = 4 to 8 run the loop. there are descriptions in each of the cells in row 4 so i don't see why it would work for 2 instantness and then fail ?
I dont know if this would make it easier but I have the number of sheets i want to create in cell C4 so i could use this rather than looking up populated cells. so if C4 is 2 then I want to add 2 sheets named as the content of D4, E4. if C4 is 3 then I want to add 3 sheets names as content of D3,E3,F3. Am I making this harder than I need too ?
UPDATE
I figured out the copying over of info is affecting this loop. and amended the code to this.
Sub InsertSupplierSheet()
Dim ws As Worksheet
Dim tmpSht As Worksheet
Dim Lastcol As Integer, i As Integer, j As Integer
Dim DESCRANGE As Range
Dim sShtName As String 'Dimension sheet name variable
'~~> Change Sheet1 to the sheet which has all the data
Set ws = ThisWorkbook.Worksheets(1)
With ws
Lastcol = ActiveSheet.Cells(4, Columns.Count).End(xlToLeft).Column
If Lastcol < 4 Then Exit Sub
For i = 4 To Lastcol
sShtName = ActiveSheet.Cells(4, i).Value2 'Set sShtName to cell value within loop
If DoesSheetExist(sShtName) Then 'Use sShtName to call "Exists" function
Set tmpSht = Sheets(sShtName)
Else
Sheets.Add After:=Sheets(Sheets.Count)
Set tmpSht = ActiveSheet
tmpSht.Name = sShtName 'Change name to sShtName
End If
.Rows("1:3").Copy tmpSht.Rows(1)
.Rows(13).Copy tmpSht.Rows(4)
Next
End With
End Sub
Function DoesSheetExist(Sht As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Sheets(Sht)
On Error GoTo 0
If Not ws Is Nothing Then DoesSheetExist = True
End Function
this is doing what i want it to do with a couple of small exceptions.
the Sheets are being named by the cells in D1 , then E13,F13,G13,H13 So i need to figure out where that info is coming from.
the final bit is that due to my conditional formatting in the First sheet, I am getting text on black backgrounds in the copy cells, but that is the very least of my worries !
UPDATE
Found the error -
sShtName = ActiveSheet.Cells(4, i).Value2
should be
sShtName = Worksheets(1).Cells(4, i).Value2
You are calling your cells incorrectly. Use (4, i) instead of (4 & i).
The way you were calling it concatenated it to 43, which resulted in you checking cell AQ1 (AQ being the 43rd column) for the sheet reference.
Edit: I just walked through it a bit and found a couple of other errors. You need to set the sheet name to sht in your 'exists' function, and I'm assuming you want to set tmpSht to a sheet, so you need to encase it in sheets(). Try this:
Sub InsertSupplierSheet()
Dim ws As Worksheet
Dim tmpSht As Worksheet
Dim Lastcol As Integer, i As Integer, j As Integer
Dim DESCRANGE As Range
Dim sShtName As String 'Dimension sheet name variable
'~~> Change Sheet1 to the sheet which has all the data
Set ws = ThisWorkbook.Worksheets(1)
With ws
Lastcol = ActiveSheet.Cells(4, Columns.Count).End(xlToLeft).Column
If Lastcol < 4 Then Exit Sub
For i = 4 To Lastcol
sShtName = ActiveSheet.Cells(4, i).Value2 'Set sShtName to cell value within loop
If DoesSheetExist(sShtName) Then 'Use sShtName to call "Exists" function
Set tmpSht = Sheets(sShtName)
Else
Sheets.Add After:=Sheets(Sheets.Count)
Set tmpSht = ActiveSheet
tmpSht.Name = sShtName 'Change name to sShtName
End If
.Rows("1:3").Copy tmpSht.Rows(1)
For j = 1 To 4
tmpSht.Columns(j).ColumnWidth = .Columns(j).ColumnWidth
Next j
.Rows(i).Copy tmpSht.Rows(4)
Next
End With
End Sub
Function DoesSheetExist(Sht As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Sheets(Sht)
On Error GoTo 0
If Not ws Is Nothing Then DoesSheetExist = True
End Function
Instead of adding the new sheet and then setting the activesheet to the tmpsht you could use a shorter way (see below). And why did you set the ws if you don't use it....
Sub InsertSupplierSheet()
Dim ws As Worksheet
Dim tmpSht As Worksheet
Dim Lastcol As Integer, i As Integer, j As Integer
Dim DESCRANGE As Range
Set ws = ThisWorkbook.Worksheets(1)
With ws
Lastcol = .Cells(4, .Columns.Count).End(xlToLeft).Column
If (Lastcol < 4) Then
Exit Sub
End If
For i = 4 To Lastcol
If (DoesSheetExist(.Cells(4, i).Value2) = True) Then
Set tmpSht = Sheets(.Cells(4, i).Value)
Else
Set tmpSht = Sheets.Add After:=Sheets(Sheets.Count)
tmpSht.Name = "NEWSHEET"
End If
.Rows("1:3").Copy tmpSht.Rows(1)
For j = 1 To 4
tmpSht.Columns(j).ColumnWidth = .Columns(j).ColumnWidth
Next j
.Rows(i).Copy tmpSht.Rows(4)
Next i
End With
End Sub
Function DoesSheetExist(Sht As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Sheets(Sht)
On Error GoTo 0
If Not ws Is Nothing Then
DoesSheetExist = True
Else
DoesSheetExist = False
End If
End Function
This was my final code. There were a few tweaks, Firstly I added a formula in row 6 to shorten the name of row 4 to a 10 character name as I found the tab names were too long (hence the code for the naming refers to row 6. I also added some custom text to add into each sheet and some formatting
Option Explicit
Sub InsertSupplierSheet()
Dim ws As Worksheet
Dim tmpSht As Worksheet
Dim Lastcol As Integer
Dim i As Integer
Dim j As Integer
Dim DESCRANGE As Range
Dim sShtName As String 'Dimension sheet name variable
'~~> Change Sheet1 to the sheet which has all the data
Set ws = ThisWorkbook.Worksheets(1)
With ws
Lastcol = ActiveSheet.Cells(4, Columns.Count).End(xlToLeft).Column ' work with the template sheet
If Lastcol = 3 Then Exit Sub 'repeat these steps from the first config to the last
For i = 4 To Lastcol
sShtName = Worksheets(1).Cells(6, i).Value2 'Set sShtName to cell value within loop
If DoesSheetExist(sShtName) Then 'Use sShtName to call "Exists" function
Set tmpSht = Sheets(sShtName)
Else
Sheets.Add After:=Sheets(Sheets.Count)
Set tmpSht = ActiveSheet
tmpSht.Name = sShtName 'Change name to sShtName tmpSht.Name = sShtName
End If
.Rows("1:3").Copy tmpSht.Rows(1) ' Format the cell width in the new sheet
.Rows(13).Copy tmpSht.Rows(4)
tmpSht.Range("A1").Value = Worksheets(1).Cells(4, i).Value2
Range("A1").ColumnWidth = 30
Range("B1").ColumnWidth = 0
Range("C1").ColumnWidth = 30
Range("D1:K1").ColumnWidth = 10
Range("D4:J4").Font.Color = vbWhite ' format the colour of the text in the new sheet
Range("C1") = " " ' Negate info in cell C1
With Range("A1:M5") ' add borders
'Clear existing
.Borders.LineStyle = xlNone
'Apply new borders
.BorderAround xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
End With
With Range("A1:C4") ' set colours for the new sheet
.Font.Color = vbBlack
.Interior.Color = vbWhite
End With
Range("D4:J4").Font.Color = vbWhite ' set colour of the numbers to white to show on black background
Range("A5") = "Unit cost in " & Worksheets(1).Cells(17, 3).Value2
Range("A6") = "CUSTOM TEXT ONE."
Range("A7") = "NOTE if quantity " & Range("D4").Value2 + 5 & " is ordered then total cost will be your unit cost for " & Range("D4").Value2 & " multiplied by " & Range("D4").Value2 + 5 & " .This applies up to the quantity of " & Range("E4").Value2 - 1
Range("A8") = "CUSTOM TEXT 2"
Next i
End With
End Sub
Function DoesSheetExist(Sht As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Sheets(Sht)
On Error GoTo 0
If Not ws Is Nothing Then DoesSheetExist = True
End Function