Macro to check if cells ("G13:J13") have values in them

  • Thread starter Thread starter Juracy
  • Start date Start date
J

Juracy

Hello everbody , I need help to create a macro(I just start to use macro).
So I'm looking for a macro that will check two situation.
Situation 1 - If a cell has any value in each cell in a rage let's say
Sheets("Sheet1").Range("G13:J13") them copy Range("C13:D13,G13:J13") to
("Sheet2") column "F" next empty line paste that multiple range after that,
go back to Sheets("Sheet1").Range("G14:J14") check again if is not empty , if
not copy Range("C14:D14,G14:J14") to ("Sheet2") column "F" next empty line
paste that multiple range and than so on...untill reach
Range("G55:J55").After that in Sheets("Sheet1") all ranges where were copied
before just clean thos values.

Thanks for any help - Juracy
 
Something like this perhaps: Make a copy of your file and then run this
macro on the copy to make sure it does what you want. HTH Otto
Sub CopyStuff()
Dim i As Range, RngToCopy As Range, Dest As Range
Sheets("Sheet1").Select
Set Dest = Sheets("Sheet2").Range("F" & Rows.Count).End(xlUp).Offset(1)
Set RngToCopy = Range("C1:D1,G1:J1")
For Each i In Range("G13", "G55")
If Application.CountA(i.Resize(, 2)) = 2 Then
RngToCopy.Offset(i.Row - 1).Copy Dest
RngToCopy.Offset(i.Row - 1).ClearContents
Set Dest = Dest.Offset(1)
End If
Next i
End Sub
 
Hi Otto thank you for your reply really appreciate that,

I din't say but in Sheets("Sheet1").Range("C13:D13") need to copy it if
Range("G13:J13") has some value, so if Range("G13:J13") has value copy
Range("C13:G13") and Range("G13:J13") to sheet2 column F next empty line,
go back to sheet1 check Range("G14:J14") if has value copy Range("C14:G14")
and Range("G14:J14") to sheet2 column F next empty line util reach line 27 so
that verification start in line 13 until 27 after that clean
Range("G13:J13"),Range("G14:J14") ...if those had some value.
Them from line 27 jump to line 32 and start same verification above from
line 32 Range("G32:J32") till Range("G55:J55").



Thank you from Brazil
Juracy
 
Try This. HTH Otto
Sub CopyStuff()
Dim i As Range, RngToCopy As Range, Dest As Range
Sheets("Sheet1").Select
Set Dest = Sheets("Sheet2").Range("F" & Rows.Count).End(xlUp).Offset(1)
Set RngToCopy = Range("C1:D1,G1:J1")
For Each i In Range("G13", "G27")
If Application.CountA(i.Resize(, 2)) = 2 Then
RngToCopy.Offset(i.Row - 1).Copy Dest
RngToCopy.Offset(i.Row - 1).ClearContents
Set Dest = Dest.Offset(1)
End If
Next i
For Each i In Range("G32", "G55")
If Application.CountA(i.Resize(, 2)) = 2 Then
RngToCopy.Offset(i.Row - 1).Copy Dest
RngToCopy.Offset(i.Row - 1).ClearContents
Set Dest = Dest.Offset(1)
End If
Next i
End Sub
 
Hello everybody.
I had some more change in my macro and now look a better code.

Just wanna share with all.
Just a question, does anybody know how to deny Users to input same
information over two time?

Thank you.


Private Sub btnInsertData_Click()

Dim hw As Worksheet, iw As Worksheet 'worksheets
Dim r As Integer, c As Integer 'row, column
Dim d As Integer '"Data da visita" blocks
Dim nextRow As Long 'next row in BD

'assign worksheets
Set iw = ActiveSheet
Set hw = Worksheets("BD")

'check for required cells
If Application.CountA(Range("D3,D6,I7")) <> 3 Then
MsgBox "Por favor preencha todos campos necessários!"
Exit Sub
End If

'insert all data
c = 7
For d = 1 To 4 'Maximum "Data da visita" blocks
r = 13 'Each "Data da visita" block begins in "Alimentos para Cães /
Secos"
Do
'copy data only if any cell has a value
If iw.Cells(r, c) <> "" Or iw.Cells(r, c + 1) <> "" Or
iw.Cells(r, c + 2) <> "" Or iw.Cells(r, c + 3) <> "" Then
'take next row in BD
With hw
nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1,
0).Row
End With
'copy fixed data
hw.Cells(nextRow, "A") = Now
hw.Cells(nextRow, "B") = Application.UserName
hw.Cells(nextRow, "C") = Application.Version
hw.Cells(nextRow, "D") = Application.OperatingSystem
hw.Cells(nextRow, "E") = Application.MailSystem
hw.Cells(nextRow, "F") = iw.Range("D3")
hw.Cells(nextRow, "G") = iw.Range("D6")
hw.Cells(nextRow, "H") = iw.Cells(7, c + 2) 'current block
date
'copy data from this block
hw.Cells(nextRow, "I") = iw.Cells(r, 3)
hw.Cells(nextRow, "J") = iw.Cells(r, 4)
hw.Cells(nextRow, "K") = iw.Cells(r, c)
hw.Cells(nextRow, "L") = iw.Cells(r, c + 1)
hw.Cells(nextRow, "M") = iw.Cells(r, c + 2)
hw.Cells(nextRow, "N") = iw.Cells(r, c + 3)
End If
r = r + 1
'row correction for each block
If r = 28 Then r = 32 'Alimentos para Gatos / Secos
If r = 37 Then r = 41 'Alimentos para Gatos / Úmidos
If r = 44 Then r = 48 'Alimentos para Cães / Úmidos
If r = 50 Then r = 55 'Petiscos
'
'if you have more blocks, just add here :)
'
Loop While r <= 56 'maximum row of all blocks
c = c + 5 'move to next "Data da visita"
Next
MsgBox "Concluido"
'clear all blocks
iw.Range("G13:Y56").Select
Selection.ClearContents
iw.Range("G13").Select

End Sub
 
You can use Data Validation to prevent duplicate entries. Select the
cells in which duplicates are to be prevented. From the Data menu,
choose Validation, and in the Allow list, choose Custom. Use a formula
like

=COUNTIF($A$1:$A$10,A1)=1

where $A$1:$A$10 is the range in which duplicates are to be prevented.
You need the $ characters as shown. The formula will return TRUE if
the count is 1, and therefore validation will allow the input. If
COUNTIF returns a number other than 1, the formula is FALSE and
validation will stop the entry.

Cordially,
Chip Pearson
Microsoft MVP 1998 - 2010
Pearson Software Consulting, LLC
www.cpearson.com
[email on web site]
 
You can use Data Validation to prevent duplicate entries. Select the
cells in which duplicates are to be prevented. From the Data menu,
choose Validation, and in the Allow list, choose Custom. Use a formula
like

=COUNTIF($A$1:$A$10,A1)=1

where $A$1:$A$10 is the range in which duplicates are to be prevented.
You need the $ characters as shown. The formula will return TRUE if
the count is 1, and therefore validation will allow the input. If
COUNTIF returns a number other than 1, the formula is FALSE and
validation will stop the entry.

Cordially,
Chip Pearson
Microsoft MVP 1998 - 2010
Pearson Software Consulting, LLC
www.cpearson.com
[email on web site]
 
Back
Top