28. januar 2012 - 14:25Der er
17 kommentarer og 1 løsning
kopiere ikke tomme celler
Har lidt problemer med en makro.
Den skal kunne checke om en celle indeholder karakterer, altså er <> "". Hvis den indeholder karakterer, så skal den kopiere cellen til et andet ark.
Det drejer sig om kolonne B og C, række 3 til 17, række 20 til 34, række 37 til 51, række 54 til 68, række 71 til 85, række 88 til 102, række 105 til 120
Eksempel:
Ark1:
B3 = "" B4 = "" B4 = test B5 = "" B6 = test2
C3 = "" C4 = "" C4 = 1 C5 = "" C6 = 2
Den skal kopiere B4 til "ark2" B2 Den skal kopiere C6 til "ark2" B3 (altså den næste under) (der vil aldrig stå tal i kolonne C hvis kolonne B, samme række er tom)
Den skal desuden tage cellen ved siden af og kopiere, så:
Række 3 til 17 har en overskrift: Denne overskrift skal med hvis der mellem række 3 og 17 i kolonne B og C er karakterer. overskriften skal stå et felt til venstre for første overførte 'navn'
I dette særtema om aspekter af AI ser vi på skiftet fra sprogmodeller til AI-agenter, og hvordan virksomheder kan navigere i spændet mellem teknologisk hastighed og behovet for menneskelig kontrol.
Se denne VBA kode - ikke den mest elegante med den løser din opgave:
Sub Copy_Records()
Dim i As Integer, j As Integer, k As Integer Dim MyRange As Range, MyArea As Range Dim C As Variant
Set Area_1 = Range("B3:B17") Set Area_2 = Range("B20:B34") Set Area_3 = Range("B37:B51") Set Area_4 = Range("B54:B68") Set Area_5 = Range("B71:B85") Set Area_6 = Range("B88:B102") Set Area_7 = Range("B105:B120")
'Stop j = 0 'Gennemløber alle områder
Application.ScreenUpdating = False
For i = 1 To 7
Select Case i
Case 1 Set MyArea = Area_1 Case 2 Set MyArea = Area_2 Case 3 Set MyArea = Area_3 Case 4 Set MyArea = Area_4 Case 5 Set MyArea = Area_5 Case 6 Set MyArea = Area_6 Case 7 Set MyArea = Area_7
End Select
Set MyRange = MyArea k = 0
For Each C In MyRange If Not (IsEmpty(C)) Then If k = 0 Then j = j + 1 MyRange.Offset(-1, 0).Resize(1, 1).Copy Sheets("Ark5").Range("A2").Offset(j, 0).PasteSpecial End If C.Copy Sheets("Ark5").Range("B2").Offset(j, 0).PasteSpecial C.Offset(0, 1).Copy Sheets("Ark5").Range("C2").Offset(j, 0).PasteSpecial j = j + 1 k = k + 1 End If
Det eneste der mangler overskriften - den kommer ikke med. Hvis det er muligt vil jeg også gerne have underoverskriften overført.
Underoverskriften ligger i cellen under overskriften.
Og lige en sidste ting, hvis du har mod på det: Jeg kunne godt tænkte mig, at denne denne macro blev kørt på 7 ark, sådan at det hele kom til at stå under hinanden.
I cellen over 'overskriften' skal arknavnet så indsættes.
Dim i As Integer, j As Integer, k As Integer, n As Integer Dim MyRange As Range, MyArea As Range Dim C As Variant
Set Area_1 = Range("B3:B17") Set Area_2 = Range("B20:B34") Set Area_3 = Range("B37:B51") Set Area_4 = Range("B54:B68") Set Area_5 = Range("B71:B85") Set Area_6 = Range("B88:B102") Set Area_7 = Range("B105:B120")
j = 0 'Gennemløber alle områder
Application.ScreenUpdating = False
For i = 1 To 7
Select Case i
Case 1 Set MyArea = Area_1 Case 2 Set MyArea = Area_2 Case 3 Set MyArea = Area_3 Case 4 Set MyArea = Area_4 Case 5 Set MyArea = Area_5 Case 6 Set MyArea = Area_6 Case 7 Set MyArea = Area_7
End Select
Set MyRange = MyArea k = 0
For Each C In MyRange If Not (IsEmpty(C)) Then If k = 0 Then j = j + 1 MyRange.Offset(0, -1).Resize(1, 1).Copy Sheets("Ark5").Range("A2").Offset(j, 0).PasteSpecial MyRange.Offset(1, -1).Resize(1, 1).Copy Sheets("Ark5").Range("A2").Offset(j + 1, 0).PasteSpecial End If C.Copy Sheets("Ark2").Range("B2").Offset(j, 0).PasteSpecial C.Offset(0, 1).Copy Sheets("Ark5").Range("C2").Offset(j, 0).PasteSpecial j = j + 1 k = k + 1 End If
Case 0 Sheet_Name = "Ark1" Copy_Records Sheet_Name Case 1 Sheet_Name = "Ark2" Copy_Records Sheet_Name Case 2 Sheet_Name = "Ark3" Copy_Records Sheet_Name Case 3 Sheet_Name = "Ark4" Copy_Records Sheet_Name Case 4 Sheet_Name = "Ark5" Copy_Records Sheet_Name Case 5 Sheet_Name = "Ark6" Copy_Records Sheet_Name Case 6 Sheet_Name = "Ark7" Copy_Records Sheet_Name End Select
Next n
Application.ScreenUpdating = True
End Sub
Sub Copy_Records(SheetName As String)
Dim i As Integer, k As Integer Dim MyRange As Range, MyArea As Range Dim C As Variant
Set Area_1 = Sheets(SheetName).Range("B3:B17") Set Area_2 = Sheets(SheetName).Range("B20:B34") Set Area_3 = Sheets(SheetName).Range("B37:B51") Set Area_4 = Sheets(SheetName).Range("B54:B68") Set Area_5 = Sheets(SheetName).Range("B71:B85") Set Area_6 = Sheets(SheetName).Range("B88:B102") Set Area_7 = Sheets(SheetName).Range("B105:B120")
'j = 0 'Gennemløber alle områder
For i = 1 To 7
Select Case i
Case 1 Set MyArea = Area_1 Case 2 Set MyArea = Area_2 Case 3 Set MyArea = Area_3 Case 4 Set MyArea = Area_4 Case 5 Set MyArea = Area_5 Case 6 Set MyArea = Area_6 Case 7 Set MyArea = Area_7
End Select
Set MyRange = MyArea k = 0
For Each C In MyRange If Not (IsEmpty(C)) Then If k = 0 Then j = j + 1 Sheets("Ark8").Range("A2").Offset(j - 1, 0) = SheetName MyRange.Offset(0, -1).Resize(1, 1).Copy Sheets("Ark8").Range("A2").Offset(j, 0).PasteSpecial MyRange.Offset(1, -1).Resize(1, 1).Copy Sheets("Ark8").Range("A2").Offset(j + 1, 0).PasteSpecial End If C.Copy Sheets("Ark8").Range("B2").Offset(j, 0).PasteSpecial C.Offset(0, 1).Copy Sheets("Ark8").Range("C2").Offset(j, 0).PasteSpecial j = j + 1 k = k + 1 End If
Case 0 Sheet_Name = "Ark1" Copy_Records Sheet_Name If k = 1 Then j = j + 1 Case 1 Sheet_Name = "Ark2" Copy_Records Sheet_Name If k = 1 Then j = j + 1 Case 2 Sheet_Name = "Ark3" Copy_Records Sheet_Name If k = 1 Then j = j + 1 Case 3 Sheet_Name = "Ark4" Copy_Records Sheet_Name If k = 1 Then j = j + 1 Case 4 Sheet_Name = "Ark5" Copy_Records Sheet_Name If k = 1 Then j = j + 1 Case 5 Sheet_Name = "Ark6" Copy_Records Sheet_Name If k = 1 Then j = j + 1 Case 6 Sheet_Name = "Ark7" Copy_Records Sheet_Name End Select
Next n
Application.ScreenUpdating = True
End Sub
Sub Copy_Records(SheetName As String)
Dim i As Integer Dim MyRange As Range, MyArea As Range Dim C As Variant
Set Area_1 = Sheets(SheetName).Range("B3:B17") Set Area_2 = Sheets(SheetName).Range("B20:B34") Set Area_3 = Sheets(SheetName).Range("B37:B51") Set Area_4 = Sheets(SheetName).Range("B54:B68") Set Area_5 = Sheets(SheetName).Range("B71:B85") Set Area_6 = Sheets(SheetName).Range("B88:B102") Set Area_7 = Sheets(SheetName).Range("B105:B120")
'j = 0 'Gennemløber alle områder
For i = 1 To 7
Select Case i
Case 1 Set MyArea = Area_1
Case 2 Set MyArea = Area_2 If k = 1 Then j = j + 1 Case 3 Set MyArea = Area_3 If k = 1 Then j = j + 1 Case 4 Set MyArea = Area_4 If k = 1 Then j = j + 1 Case 5 Set MyArea = Area_5 If k = 1 Then j = j + 1 Case 6 Set MyArea = Area_6 If k = 1 Then j = j + 1 Case 7 Set MyArea = Area_7 End Select
Set MyRange = MyArea k = 0
For Each C In MyRange If Not (IsEmpty(C)) Then If k = 0 Then j = j + 2 Sheets("Ark8").Range("A2").Offset(j - 1, 0) = SheetName MyRange.Offset(0, -1).Resize(1, 1).Copy Sheets("Ark8").Range("A2").Offset(j, 0).PasteSpecial MyRange.Offset(1, -1).Resize(1, 1).Copy Sheets("Ark8").Range("A2").Offset(j + 1, 0).PasteSpecial End If C.Copy Sheets("Ark8").Range("B2").Offset(j, 0).PasteSpecial C.Offset(0, 1).Copy Sheets("Ark8").Range("C2").Offset(j, 0).PasteSpecial j = j + 1 k = k + 1 End If
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.
